Macro Question

C

CARBOB

Well-known Member
Joined
Jun 6, 2005
Messages
1,870
First of all, I know nothing about macros. I have a workbook and I want to add more sheets. Do those sheets have to be named in the macro? I've tried adding a sheet that pulls data from another sheet created by the macro. That's the only relation it has with the macro. If I remove the sheet from the workbook,the macro works great. With the sheet included, the macro rus very slow. Sometimes even stops. Does anyone have any suggestions?

Carbob
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sort by date Sort by votes
Hello,

Can you post the code? And you're speaking about the new sheet, the first one you added, slowing down your code?

Yes, you probably do want to name your sheet in your procedure.
 
Upvote 0
I hope this is what you mean. The name of the sheet I want to insert is "FILTERS". Thanks for responding.

Carbob

Code: 
MODULE 1

Option Explicit
Public Const AllVtracsSheet = "ALLSTATESVTRACDRAWS"
Public Const AllDrawsSheet = "ALLSTATESDRAWS"

Public Const CombosSheet = "CASH3 COMBOS"
Public Const DrawsSheet = "MIRRORSMATESTOTALS"

Public ShtName
Dim Val, Val3, x, y, z, rng1, rng2, rng3, rng4, rng5, rngx, lc, lr
Dim dRow, dCol, Con1, Con2, Con3, Con4, Con5, Pos1, Pos2, Pos3, rng1Addr


Sub Make999List()

Sheets(CombosSheet).Select

'clear contents
Range("A2").Select
y = Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Rows.Count + 10
Range("a2:e" & y).ClearContents
Range("a2:e" & y).FormatConditions.Delete

Val = 0
For y = 2 To 1001
    rng1 = "a" & y
    rng2 = "b" & y
    rng3 = "c" & y
    rng4 = "d" & y
    rng5 = "e" & y
    
    'create initial numbers
    Range(rng1).NumberFormat = "@"
    If Len(Val) = 3 Then Range(rng1) = Val
    If Len(Val) = 2 Then Range(rng1) = "0" & Val
    If Len(Val) = 1 Then Range(rng1) = "00" & Val
    
   
    'check for mate
    For x = 0 To 9
        z = Right(Str("1" & x & x), 2)
        If InStr(Range(rng1), z) = 1 Then
            Range(rng2) = Right(Range(rng1), 1) & Right(Range(rng1), 1) & Left(Range(rng1), 1)
        ElseIf InStr(Range(rng1), z) = 2 Then
                Range(rng2) = Right(Range(rng1), 1) & Left(Range(rng1), 1) & Left(Range(rng1), 1)
                
        ElseIf Left(Range(rng1), 1) = Right(Range(rng1), 1) Then
                Range(rng2) = Mid(Range(rng1), 2, 1) & Left(Range(rng1), 1) & Mid(Range(rng1), 2, 1)
                
        End If
        
        
        Next x
    'If Len(Range(rng2)) = 3 Then Range(rng1) = Val
    Range(rng2).NumberFormat = "@"
    If Len(Range(rng2)) = 2 Then Range(rng2) = "0" & Range(rng2)
    If Len(Range(rng2)) = 1 Then Range(rng2) = "00" & Range(rng2)
    
    
    'check for mirrors
    'If Len(Range(rng2)) > 0 Then
    '    rngx = rng2
    '    Else: rngx = rng1
    '    End If
        
    Val3 = ""
    For x = 1 To 3
        z = Mid(Range(rng1), x, 1)
        If z = 0 Then Val3 = Val3 & "5"
        If z = 1 Then Val3 = Val3 & "6"
        If z = 2 Then Val3 = Val3 & "7"
        If z = 3 Then Val3 = Val3 & "8"
        If z = 4 Then Val3 = Val3 & "9"
        If z = 5 Then Val3 = Val3 & "0"
        If z = 6 Then Val3 = Val3 & "1"
        If z = 7 Then Val3 = Val3 & "2"
        If z = 8 Then Val3 = Val3 & "3"
        If z = 9 Then Val3 = Val3 & "4"
        Next x
    Range(rng3) = Val3
    Range(rng3).NumberFormat = "@"
    If Len(Range(rng3)) = 2 Then Range(rng3) = "0" & Range(rng3)
    If Len(Range(rng3)) = 1 Then Range(rng3) = "00" & Range(rng3)
    
    
    'check for mates of mirrors
    For x = 0 To 9
        z = Right(Str("1" & x & x), 2)
        If InStr(Range(rng2), z) = 1 Then
            Range(rng4) = Right(Range(rng3), 1) & Right(Range(rng3), 1) & Left(Range(rng3), 1)
        ElseIf InStr(Range(rng3), z) = 2 Then
                Range(rng4) = Right(Range(rng3), 1) & Left(Range(rng3), 1) & Left(Range(rng3), 1)
        ElseIf Left(Range(rng3), 1) = Right(Range(rng3), 1) Then
                Range(rng4) = Mid(Range(rng3), 2, 1) & Left(Range(rng3), 1) & Mid(Range(rng3), 2, 1)
        End If
        Next x
    'If Len(Range(rng2)) = 3 Then Range(rng1) = Val
    Range(rng4).NumberFormat = "@"
    If Len(Range(rng4)) = 2 Then Range(rng4) = "0" & Range(rng4)
    If Len(Range(rng4)) = 1 Then Range(rng4) = "00" & Range(rng4)
    
    'make totals
    'If Len(Range(rng4)) > 0 Then
        Range(rng5) = 999 - Range(rng1)
        Range(rng5).NumberFormat = "@"
        If Len(Range(rng5)) = 2 Then Range(rng5) = "0" & Range(rng5)
        If Len(Range(rng5)) = 1 Then Range(rng5) = "00" & Range(rng5)
    '   End If
    
    Val = Val + 1
    Next y
Application.ErrorCheckingOptions.NumberAsText = False

'apply conditional formatting
rng2 = "a2:e" & y
Range("a2").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=OR(LEFT(A2)=MID(A2,2,1),MID(A2,2,1)=RIGHT(A2),LEFT(A2)=RIGHT(A2))"
    Selection.FormatConditions(1).Font.ColorIndex = 3
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    Range(rng2).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("B11").Select
    Application.CutCopyMode = False
    Range("a1").Select
    Range("f1").Select






End Sub

Sub MakeDrawList()

Sheets(DrawsSheet).Select

'clear contents
Range("c10") = "1"
Range("A2").Select
y = Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Rows.Count
'MsgBox y
Range("a2:g" & y).ClearContents
Range("a2:g" & y).FormatConditions.Delete

'setup input range
lc = Sheets(ShtName).Range("iv1").End(xlToLeft).Column
lr = Sheets(ShtName).Range("a65536").End(xlUp).Row

z = 2
For dRow = 2 To lr
    If IsDate(Sheets(ShtName).Cells(dRow, 1)) And Sheets(ShtName).Cells(dRow, 1) > 0 Then
        If DateValue(Sheets(ShtName).Cells(dRow, 1)) >= DateValue(Range("n1")) And DateValue(Sheets(ShtName).Cells(dRow, 1)) <= DateValue(Range("n2")) Then
        
        For dCol = 2 To lc
            If Application.WorksheetFunction.IsError(Sheets(ShtName).Cells(dRow, dCol)) = False Then
            
            If LCase(Right(Sheets(ShtName).Cells(1, dCol), 2)) <> "vt" Then
                If Sheets(ShtName).Cells(dRow, dCol) > 0 Then
                    Range("a" & z) = Sheets(ShtName).Cells(dRow, 1)
                    Range("b" & z) = Sheets(ShtName).Cells(dRow, dCol)
                    Range("g" & z) = Sheets(ShtName).Cells(1, dCol)
                
                    Range("a" & z).NumberFormat = "mm/dd/yy;@"
                    Range("b" & z).NumberFormat = "@"
                
                    z = z + 1
                    End If
                End If
                End If
            Next dCol
        End If
        End If
    Next dRow
        
'now fill data - mates/ mirrors/ totals

Val = 0
For y = 2 To z - 1
    rng1 = "b" & y
    rng2 = "c" & y
    rng3 = "d" & y
    rng4 = "e" & y
    rng5 = "f" & y
    'create initial numbers
    Range(rng1).Select
    
    Val = Range(rng1)
    
    Range(rng1).NumberFormat = "@"
    If Len(Val) = 3 Then Range(rng1) = Val
    If Len(Val) = 2 Then Range(rng1) = "0" & Val
    If Len(Val) = 1 Then Range(rng1) = "00" & Val
   
    'check for mate
    For x = 0 To 9
        z = Right(Str("1" & x & x), 2)
        If InStr(Range(rng1), z) = 1 Then
            Range(rng2) = Right(Range(rng1), 1) & Right(Range(rng1), 1) & Left(Range(rng1), 1)
        ElseIf InStr(Range(rng1), z) = 2 Then
                Range(rng2) = Right(Range(rng1), 1) & Left(Range(rng1), 1) & Left(Range(rng1), 1)
                
        ElseIf Left(Range(rng1), 1) = Right(Range(rng1), 1) Then
                Range(rng2) = Mid(Range(rng1), 2, 1) & Left(Range(rng1), 1) & Mid(Range(rng1), 2, 1)
                
        End If
        
        
        Next x
    'If Len(Range(rng2)) = 3 Then Range(rng1) = Val
    Range(rng2).NumberFormat = "@"
    If Len(Range(rng2)) = 2 Then Range(rng2) = "0" & Range(rng2)
    If Len(Range(rng2)) = 1 Then Range(rng2) = "00" & Range(rng2)
    
    
    'check for mirrors
    'If Len(Range(rng2)) > 0 Then
    '    rngx = rng2
    '    Else: rngx = rng1
    '    End If
        
    Val3 = ""
    For x = 1 To 3
        z = Mid(Range(rng1), x, 1)
        If z = 0 Then Val3 = Val3 & "5"
        If z = 1 Then Val3 = Val3 & "6"
        If z = 2 Then Val3 = Val3 & "7"
        If z = 3 Then Val3 = Val3 & "8"
        If z = 4 Then Val3 = Val3 & "9"
        If z = 5 Then Val3 = Val3 & "0"
        If z = 6 Then Val3 = Val3 & "1"
        If z = 7 Then Val3 = Val3 & "2"
        If z = 8 Then Val3 = Val3 & "3"
        If z = 9 Then Val3 = Val3 & "4"
        Next x
    Range(rng3) = Val3
    Range(rng3).NumberFormat = "@"
    If Len(Range(rng3)) = 2 Then Range(rng3) = "0" & Range(rng3)
    If Len(Range(rng3)) = 1 Then Range(rng3) = "00" & Range(rng3)
    
    
    'check for mates of mirrors
    For x = 0 To 9
        z = Right(Str("1" & x & x), 2)
        If InStr(Range(rng2), z) = 1 Then
            Range(rng4) = Right(Range(rng3), 1) & Right(Range(rng3), 1) & Left(Range(rng3), 1)
        ElseIf InStr(Range(rng3), z) = 2 Then
                Range(rng4) = Right(Range(rng3), 1) & Left(Range(rng3), 1) & Left(Range(rng3), 1)
        ElseIf Left(Range(rng3), 1) = Right(Range(rng3), 1) Then
                Range(rng4) = Mid(Range(rng3), 2, 1) & Left(Range(rng3), 1) & Mid(Range(rng3), 2, 1)
        End If
        Next x
    'If Len(Range(rng2)) = 3 Then Range(rng1) = Val
    Range(rng4).NumberFormat = "@"
    If Len(Range(rng4)) = 2 Then Range(rng4) = "0" & Range(rng4)
    If Len(Range(rng4)) = 1 Then Range(rng4) = "00" & Range(rng4)
    
    'make totals
    'If Len(Range(rng4)) > 0 Then
        Range(rng5) = 999 - Range(rng1)
        Range(rng5).NumberFormat = "@"
        If Len(Range(rng5)) = 2 Then Range(rng5) = "0" & Range(rng5)
        If Len(Range(rng5)) = 1 Then Range(rng5) = "00" & Range(rng5)
    '   End If
    
   ' Val = Val + 1
    Next y
Application.ErrorCheckingOptions.NumberAsText = False

'apply conditional formatting
rng2 = "b2:f" & y
Range("b2").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=OR(LEFT(B2)=MID(B2,2,1),MID(B2,2,1)=RIGHT(B2),LEFT(B2)=RIGHT(B2))"
    Selection.FormatConditions(1).Font.ColorIndex = 3
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    Range(rng2).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("B11").Select
    Application.CutCopyMode = False
    Range("a1").Select
    Range("h1").Select
End Sub


Sub FindCombos()

Sheets(DrawsSheet).Select

rng1Addr = Target.Address

Range(rng1Addr).NumberFormat = "@"
If Len(Range(rng1Addr)) = 2 Then Range(rng1Addr) = "0" & Range(rng1Addr)
If Len(Range(rng1Addr)) = 1 Then Range(rng1Addr) = "00" & Range(rng1Addr)

rng1 = Range(rng1Addr).Value

'clear old data
rng2 = Range(rng1Addr)(3, 1).Address & ":" & Range(rng1Addr)(8, 2).Address
Range(rng2).ClearContents

Pos1 = Left(rng1, 1)
Pos2 = Mid(rng1, 2, 1)
Pos3 = Right(rng1, 1)

'check if 3 way
Val = 0
If Pos1 = Pos2 Then Val = 1
If Pos1 = Pos3 Then Val = Val + 10
If Pos2 = Pos3 Then Val = Val + 100


If Val = 111 Then Range(rng1Addr)(3, 1) = Pos1 & Pos2 & Pos3
If Val = 1 Then
    Range(rng1Addr)(3, 1) = Pos1 & Pos2 & Pos3
    Range(rng1Addr)(4, 1) = Pos1 & Pos3 & Pos2
    Range(rng1Addr)(5, 1) = Pos3 & Pos2 & Pos1
    End If
If Val = 10 Then
    Range(rng1Addr)(3, 1) = Pos1 & Pos2 & Pos3
    Range(rng1Addr)(4, 1) = Pos1 & Pos3 & Pos2
    Range(rng1Addr)(5, 1) = Pos2 & Pos3 & Pos1
    End If
If Val = 100 Then
    Range(rng1Addr)(3, 1) = Pos1 & Pos2 & Pos3
    Range(rng1Addr)(4, 1) = Pos3 & Pos2 & Pos1
    Range(rng1Addr)(5, 1) = Pos2 & Pos1 & Pos3
    End If
    
If Val = 0 Then
    Range(rng1Addr)(3, 1) = Pos1 & Pos2 & Pos3
    Range(rng1Addr)(4, 1) = Pos1 & Pos3 & Pos2
    Range(rng1Addr)(5, 1) = Pos2 & Pos1 & Pos3
    Range(rng1Addr)(6, 1) = Pos2 & Pos3 & Pos1
    Range(rng1Addr)(7, 1) = Pos3 & Pos1 & Pos2
    Range(rng1Addr)(8, 1) = Pos3 & Pos2 & Pos1
    End If

For y = 3 To 8
    If Len(Range(rng1Addr)(y, 1)) > 0 Then Range(rng1Addr)(y, 2) = Application.WorksheetFunction.CountIf(Range("b:b"), Range(rng1Addr)(y, 1))
    Next y


End Sub


MODULE 2

Public Const DrawSheet = "ALLSTATESDRAWS"
Public Const AdminSheet = "Admin"
Public Const SourceDirectory = "c4"

Dim i, f, xPath, ThisFile, lr, xDate, xNum, LastCol, LastRow, findRow, FindCol, rng, xFile
Sub SearchFiles()

Sheets(DrawSheet).Select
answer = MsgBox("Clear existing data from ALLSTATESDRAWS Page?", vbYesNo, "Clear exsiting database?")
If answer = vbYes Then Cells.Clear

LastRow = Range("a65536").End(xlUp).Row
If LastRow < 5 Then LastRow = 5
LastCol = Range("iv1").End(xlToLeft).Column
If LastCol < 2 Then LastCol = 2

'file path
If Right(Sheets(AdminSheet).Range(SourceDirectory), 1) <> "\" Then Sheets(AdminSheet).Range(SourceDirectory) = Sheets(AdminSheet).Range(SourceDirectory) & "\"
xPath = Sheets(AdminSheet).Range(SourceDirectory)

'find all .xls files
With Application.FileSearch
    .NewSearch
    .LookIn = xPath
    .Filename = "*.xls"
    .FileType = msoFileTypeAllFiles
    .Execute
End With
With Application.FileSearch
    
    For i = 1 To .FoundFiles.Count
        f = .FoundFiles(i)
        If Right(f, 3) = "xls" Then
            If CBool(Len(Dir(f))) = True Then GetData
            End If
    Next i
End With

Beep

'sort database
Sheets(DrawSheet).Select
LastRow = Range("a65536").End(xlUp).Row
LastCol = Range("iv1").End(xlToLeft).Column
rng = "a6:" & Cells(LastRow, LastCol).Address
Worksheets(DrawSheet).Range(rng).Sort _
        Key1:=Worksheets(DrawSheet).Range("A1")
        'Key2:=Worksheets("Sheet1").Range("B1")

Beep

End Sub

Sub GetData()

ThisFile = ActiveWorkbook.Name

Workbooks.Open Filename:=f
'find filename
xFile = Replace(ActiveWorkbook.Name, ".xls", "")


'find last row
lr = Range("a65536").End(xlUp).Row
For r = 2 To lr
    xDate = Range("a" & r)
    
    If Val(xDate) > 0 Then
    
    xNum = Range("b" & r) & Range("c" & r) & Range("d" & r)
    
    'find matching row
    rng = "a1:a" & LastRow
    findRow = 0
    findRow = Application.WorksheetFunction.CountIf(Workbooks(ThisFile).Sheets(DrawSheet).Range(rng), xDate)
    If findRow > 0 Then
        xDate = DateValue(xDate) * 1
       
        findRow = Application.WorksheetFunction.Match(xDate, Workbooks(ThisFile).Sheets(DrawSheet).Range(rng), 0)
        Else
        LastRow = LastRow + 1
        findRow = LastRow
        Workbooks(ThisFile).Sheets(DrawSheet).Cells(findRow, 1) = xDate
        End If
    
    'find matching column
    rng = "a1:" & Cells(1, LastCol).Address
    FindCol = 0
    FindCol = Application.WorksheetFunction.CountIf(Workbooks(ThisFile).Sheets(DrawSheet).Range(rng), xFile)
    If FindCol > 0 Then
        
        FindCol = Application.WorksheetFunction.Match(xFile, Workbooks(ThisFile).Sheets(DrawSheet).Range(rng), 0)
        Else
        LastCol = LastCol + 1
        FindCol = LastCol
        Workbooks(ThisFile).Sheets(DrawSheet).Cells(1, FindCol) = xFile
        End If
        
    'dump data to cell at row/column co-ordinates
    Workbooks(ThisFile).Sheets(DrawSheet).Cells(findRow, FindCol) = xNum
    
    End If
    
    Next r
     
ActiveWorkbook.Close



End Sub

Edited by Nate: Added code tags
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Question
slow file help
Replies
0
Views
165
orsm6
O
N
  • Question
Macro to Clearing Contents of Row affect Validation Lists
Replies
0
Views
203
Nathan Asius
N
A
  • Solved
Opening worksheets using worksheet names in a named range
Replies
4
Views
252
anythinggoes3949
A
rjbinney
  • Solved
Error 1004 - Saving Macros in Macro-Free Workbooks
Replies
6
Views
343
rjbinney
rjbinney
J
  • Question
VBA Macros running slow out of nowhere
Replies
3
Views
197
mumps
mumps

Forum statistics

Threads
1,214,651
Messages
6,120,742
Members
448,989
Latest member
mariah3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top