Macro Question

CARBOB

Well-known Member
Joined
Jun 6, 2005
Messages
1,860
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
 

Some videos you may like

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

NateO

Legend
Joined
Feb 17, 2002
Messages
9,700
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.
 

CARBOB

Well-known Member
Joined
Jun 6, 2005
Messages
1,860
It's a huge file 3.5g, I don't think I can post it.

Carbob
 

CARBOB

Well-known Member
Joined
Jun 6, 2005
Messages
1,860
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
 

Watch MrExcel Video

Forum statistics

Threads
1,119,128
Messages
5,576,251
Members
412,709
Latest member
Rishu
Top