How to Optimize Group of Macros

C

cns324

New Member
Joined
Jan 21, 2022
Messages
37
Office Version
  1. 365
Platform
  1. Windows
Hello, I have the list of macros below all linked to a button. Next to each macro is a brief description of what they do. Then I have all the code listed for each as well. These all currently work and the button does what I need it to. However, I would like to optimize them to run quickly. When I started this, I didn't plan to have all these run together, so that is why they are individual macros. I am sure some of these are a mess because some are just recorded macros and some have come from previous posts on here. I would be ok, if the code is combined into less macros that complete the same things. I new to VBA so any feedback or suggestions are greatly appreciated. Unfortunately I can't post the spreadsheet.

Sub button3_Click()
Call export: selects the opened export workbook
Call paste: copies the data in the export workbook and pastes it in sheet1 of the servicenow workbook.
Call Step1: adds date to 1st column of Sheet1, then adds current date for all of items, deletes columns titled actions, escalated, description, USD amount, OBO, and approving as.
Call FullDelete: deletes any rows where "full time" is listed in Comment column
Call IndDelete: deletes any rows where "Individual" is listed in Comment column
Call ResDelete: deletes any rows where "Resiliency" is listed in Comment column
Call Step2; cuts and pastes the remaining rows in sheet1 tab to the service now requests tab.
Call RemoveDups: Checks and removes any duplicated numbers in column E on service now tab, deletes full row
Call removeperiod: remove the periods from names, this helps the vlookup work correctly
Call vlook1: does a vlookup for the approval note, pulls the approval note from column F from Projects tab.
Call vlook2: copies and pastes column L as text
Call moveRelocs: Moves any Change, relocations, and Removes to Toni's Sheet and deletes duplicates
Call vlook3: does a vlookup for the approve notes for Toni's Review Sheet from sheet2.
Call vlook2: copies and pastes column L as text
Call Formating: This one compares column E on service now sheet to all of column E on the Completed Tab. Highlights any duplicates. (Would like this to also highlight any duplicates in column E on the Toni Review sheet when compared E on the completed tab also)
Call CountToday: Counts how many rows were added to the both Service Now Request sheet and Other sheet with today's date. Gives it in a message box
End Sub

Sub export()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Name Like "export*" Then wb.Activate: Exit Sub
Next wb
End Sub



Sub paste()
' paste Macro
Cells.Select
Application.CutCopyMode = False
Selection.Copy
ThisWorkbook.Activate
Sheets("Sheet1").Select
Range("A1").Select
ActiveSheet.paste
End Sub



Sub Step1()
' Step1 Macro
Range("A1").Select
ActiveCell.FormulaR1C1 = "Date"
Range("A2").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("A2").Select
Selection.Copy
Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.paste
Range("B:B,C:C,H:H,I:I,L:L").Select
Range("L1").Activate
ActiveWindow.SmallScroll ToRight:=2
Range("B:B,C:C,H:H,I:I,L:L,M:M").Select
Range("M1").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
ActiveWindow.LargeScroll ToRight:=-1
Columns("A:A").ColumnWidth = 10
Range("A2").Select
End Sub



Sub FullDelete()
Dim rCell As Range
Dim cRow As Long, LastRow As Long
LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("Sheet1").Range("B1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*Full time*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
End Sub

Sub IndDelete()
Dim rCell As Range
Dim cRow As Long, LastRow As Long
LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
With Worksheets("Sheet1").Range("B1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*Individual*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
End Sub



Sub ResDelete()
Dim rCell As Range
Dim cRow As Long, LastRow As Long
LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("Sheet1").Range("B1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*Resiliency*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
End Sub



Sub Step2()
Step2 Macro
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Sheets("Service Now Requests").Select
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.paste
End Sub



Sub RemoveDups()
ActiveSheet.UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
End Sub



Sub removeperiod()
' removeperiod Macro
Columns("F:F").Select
Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End Sub



Sub vlook1()
Dim lr As Long
' Find last row in column E with data
lr = Cells(Rows.Count, "E").End(xlUp).Row
' Insert formula
Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(""*""&RC[-6]&""*"", 'Projects'!C[-10]:C[-6], 5, FALSE)"
End Sub


Sub vlook2()
' vlook2 Macro
Range("L2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("L2").Select
Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("L8").Select
End Sub





Sub moveRelocs()
Dim ws1Row As Long, ws2Row As Long, ws3Row As Long, x As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, TestRng As Range
Set ws1 = Sheet1
Set ws2 = Sheets("Completed")
Set ws3 = Sheets("Toni Review")
'1. Move the other rows
Dim i As Long, c As Range, arr() As Variant
ws3Row = ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
ws1Row = ws1.Cells(Rows.Count, 2).End(xlUp).Row
x = Evaluate("Sum(COUNTIF(B2:B" & ws1Row & ",{""*Remove*"",""*Change *"",""*Relocat*""}))")
If x = 0 Then
MsgBox "No Remove, Change or Relocation records found"
Exit Sub
End If
For Each c In ws1.Range("B2:B" & ws1Row)
If c.Value Like "*Remove*" Or _
c.Value Like "*Change*" Or _
c.Value Like "*Relocation*" Then
ReDim Preserve arr(i)
arr(i) = c.Value
i = i + 1
End If
Next c
With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
.AutoFilter 2, Array(arr), 7
.Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(ws3Row, 1)
.Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
.AutoFilter
ws3.UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
End With
End Sub


Sub vlook3()
Sheet4.Activate
Dim lr As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(RC[-10],Sheet2!R1C1:R8C2, 2, FALSE)"
End Sub



Sub vlook2()
' vlook2 Macro
Range("L2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("L2").Select
Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("L8").Select
End Sub


This one compares column E on service now sheet to all of column E on the Completed Tab. Highlights any duplicates. (Would like this to also highlight any duplicates in column E on the Toni Review sheet when compared E on the completed tab also)
Sub Formating()
' Formating Macro
Sheet1.Activate
Columns("E:E").Select
Selection.FormatConditions.Delete
Range("E2").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(Completed!$E:$E,$E2)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.Copy
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub

Sub CountToday()
MsgBox Application.WorksheetFunction.CountIf(Sheets("Service Now Requests").Range("A:A"), Date) + Application.WorksheetFunction.CountIf(Sheets("Toni Review").Range("A:A"), Date) & " Requests Added"
End Sub
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
See if the following version performs like the original codes you posted:

VBA Code: 
Sub export()
'
    Dim wb As Workbook
'
    For Each wb In Application.Workbooks
        If wb.Name Like "export*" Then
            wb.Activate
            Exit Sub
        End If
    Next wb
'
' paste Macro
    Cells.Copy ThisWorkbook.Sheets("Sheet1").Range("A1")
'
' Step1 Macro
    With ThisWorkbook.Sheets("Sheet1")
        .Range("A1").FormulaR1C1 = "Date"           ' <--- Don't need a formula for a string
        .Range("A2").FormulaR1C1 = "=TODAY()"
        .Range("A2").Copy
        .Range("A2").PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        .Range("A2").Copy .Range(.Range("A3"), .Range("A3").End(xlDown))
        .Range("B:C,H:I,L:M").Delete Shift:=xlToLeft
        .Columns("A:A").ColumnWidth = 10
        .Select
        .Range("A2").Select
    End With
'
' FullDelete Macro
    Dim cRow    As Long, LastRow    As Long
    Dim rCell   As Range                                                    ' <-- This variable is not used (c is used)
'
    LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'
    With Worksheets("Sheet1").Range("B1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
        Do
            Set c = .Find(What:="*Full time*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
'
' IndDelete Macro
        LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
'
        Do
            Set c = .Find(What:="*Individual*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
'
' ResDelete Macro
        LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'
        Do
            Set c = .Find(What:="*Resiliency*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
    End With
'
' Step2 Macro
    Worksheets("Sheet1").Range(Worksheets("Sheet1").Rows("2:2"), Worksheets("Sheet1").Rows("2:2").End(xlDown)).Cut _
            Sheets("Service Now Requests").Range("A" & Rows.Count).End(xlUp).Offset(1)
'
' RemoveDups Macro
    Sheets("Service Now Requests").UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
'
' removeperiod Macro
    Sheets("Service Now Requests").Columns("F:F").Replace What:=".", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByColumns, _
            MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'
' vlook1 Macro
    Dim lr As Long
'
    lr = Sheets("Service Now Requests").Cells(Sheets("Service Now Requests").Rows.Count, "E").End(xlUp).Row       ' Find last row in column E with data
    Sheets("Service Now Requests").Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(""*""&RC[-6]&""*"", 'Projects'!C[-10]:C[-6], 5, FALSE)"   ' Insert formula
'
' vlook2 Macro
    Sheets("Service Now Requests").Select
    Range(Range("L2"), Range("L2").End(xlDown)).Copy
    Range("L2").PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("L8").Select
'
' moveRelocs Macro
    Dim ws1Row As Long, ws2Row As Long, ws3Row As Long, x As Long, i As Long
    Dim c As Range, TestRng As Range
    Dim arr() As Variant
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
'
    Set ws1 = Sheet1
    Set ws2 = Sheets("Completed")
    Set ws3 = Sheets("Toni Review")
'
'1. Move the other rows
    ws3Row = ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
    ws1Row = ws1.Cells(Rows.Count, 2).End(xlUp).Row
    x = Evaluate("Sum(COUNTIF(B2:B" & ws1Row & ",{""*Remove*"",""*Change *"",""*Relocat*""}))")
'
    If x = 0 Then
        MsgBox "No Remove, Change or Relocation records found"
        Exit Sub
    End If
'
    For Each c In ws1.Range("B2:B" & ws1Row)
        If c.Value Like "*Remove*" Or c.Value Like "*Change*" Or c.Value Like "*Relocation*" Then
            ReDim Preserve arr(i)
'
            arr(i) = c.Value
            i = i + 1
        End If
    Next c
'
    With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
        .AutoFilter 2, Array(arr), 7
        .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(ws3Row, 1)
        .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        .AutoFilter
        ws3.UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
    End With
'
' vlook3 Macro
    Sheet4.Activate
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(RC[-10],Sheet2!R1C1:R8C2, 2, FALSE)"
'
' Second_vlook2 Macro
    Range(Range("L2"), Range("L2").End(xlDown)).Copy
    Range("L2").PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("L8").Select
'
' Formating Macro
'This one compares column E on service now sheet to all of column E on the Completed Tab. Highlights any duplicates. (Would like this
'to also highlight any duplicates in column E on the Toni Review sheet when compared E on the completed tab also)
'
    Sheet1.Columns("E:E").FormatConditions.Delete
    Sheet1.Range("E2").FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF(Completed!$E:$E,$E2)"
    Sheet1.Range("E2").FormatConditions(Sheet1.Range("E2").FormatConditions.Count).SetFirstPriority
'
    With Sheet1.Range("E2").FormatConditions(1)
        .Interior.PatternColorIndex = xlAutomatic
        .Interior.Color = 65535
        .Interior.TintAndShade = 0
        .StopIfTrue = False
    End With
'
    Sheet1.Range("E2").Copy
    Sheet1.Range(Sheet1.Range("E2"), Sheet1.Range("E2").End(xlDown)).PasteSpecial paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
'
' CountToday Macro
    MsgBox Application.WorksheetFunction.CountIf(Sheets("Service Now Requests").Range("A:A"), Date) + _
            Application.WorksheetFunction.CountIf(Sheets("Toni Review").Range("A:A"), Date) & " Requests Added"

End Sub
 
Upvote 0
johnnyL said:
See if the following version performs like the original codes you posted:

VBA Code: 
Sub export()
'
    Dim wb As Workbook
'
    For Each wb In Application.Workbooks
        If wb.Name Like "export*" Then
            wb.Activate
            Exit Sub
        End If
    Next wb
'
' paste Macro
    Cells.Copy ThisWorkbook.Sheets("Sheet1").Range("A1")
'
' Step1 Macro
    With ThisWorkbook.Sheets("Sheet1")
        .Range("A1").FormulaR1C1 = "Date"           ' <--- Don't need a formula for a string
        .Range("A2").FormulaR1C1 = "=TODAY()"
        .Range("A2").Copy
        .Range("A2").PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        .Range("A2").Copy .Range(.Range("A3"), .Range("A3").End(xlDown))
        .Range("B:C,H:I,L:M").Delete Shift:=xlToLeft
        .Columns("A:A").ColumnWidth = 10
        .Select
        .Range("A2").Select
    End With
'
' FullDelete Macro
    Dim cRow    As Long, LastRow    As Long
    Dim rCell   As Range                                                    ' <-- This variable is not used (c is used)
'
    LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'
    With Worksheets("Sheet1").Range("B1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
        Do
            Set c = .Find(What:="*Full time*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
'
' IndDelete Macro
        LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
'
        Do
            Set c = .Find(What:="*Individual*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
'
' ResDelete Macro
        LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'
        Do
            Set c = .Find(What:="*Resiliency*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
    End With
'
' Step2 Macro
    Worksheets("Sheet1").Range(Worksheets("Sheet1").Rows("2:2"), Worksheets("Sheet1").Rows("2:2").End(xlDown)).Cut _
            Sheets("Service Now Requests").Range("A" & Rows.Count).End(xlUp).Offset(1)
'
' RemoveDups Macro
    Sheets("Service Now Requests").UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
'
' removeperiod Macro
    Sheets("Service Now Requests").Columns("F:F").Replace What:=".", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByColumns, _
            MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'
' vlook1 Macro
    Dim lr As Long
'
    lr = Sheets("Service Now Requests").Cells(Sheets("Service Now Requests").Rows.Count, "E").End(xlUp).Row       ' Find last row in column E with data
    Sheets("Service Now Requests").Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(""*""&RC[-6]&""*"", 'Projects'!C[-10]:C[-6], 5, FALSE)"   ' Insert formula
'
' vlook2 Macro
    Sheets("Service Now Requests").Select
    Range(Range("L2"), Range("L2").End(xlDown)).Copy
    Range("L2").PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("L8").Select
'
' moveRelocs Macro
    Dim ws1Row As Long, ws2Row As Long, ws3Row As Long, x As Long, i As Long
    Dim c As Range, TestRng As Range
    Dim arr() As Variant
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
'
    Set ws1 = Sheet1
    Set ws2 = Sheets("Completed")
    Set ws3 = Sheets("Toni Review")
'
'1. Move the other rows
    ws3Row = ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
    ws1Row = ws1.Cells(Rows.Count, 2).End(xlUp).Row
    x = Evaluate("Sum(COUNTIF(B2:B" & ws1Row & ",{""*Remove*"",""*Change *"",""*Relocat*""}))")
'
    If x = 0 Then
        MsgBox "No Remove, Change or Relocation records found"
        Exit Sub
    End If
'
    For Each c In ws1.Range("B2:B" & ws1Row)
        If c.Value Like "*Remove*" Or c.Value Like "*Change*" Or c.Value Like "*Relocation*" Then
            ReDim Preserve arr(i)
'
            arr(i) = c.Value
            i = i + 1
        End If
    Next c
'
    With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
        .AutoFilter 2, Array(arr), 7
        .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(ws3Row, 1)
        .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        .AutoFilter
        ws3.UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
    End With
'
' vlook3 Macro
    Sheet4.Activate
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(RC[-10],Sheet2!R1C1:R8C2, 2, FALSE)"
'
' Second_vlook2 Macro
    Range(Range("L2"), Range("L2").End(xlDown)).Copy
    Range("L2").PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("L8").Select
'
' Formating Macro
'This one compares column E on service now sheet to all of column E on the Completed Tab. Highlights any duplicates. (Would like this
'to also highlight any duplicates in column E on the Toni Review sheet when compared E on the completed tab also)
'
    Sheet1.Columns("E:E").FormatConditions.Delete
    Sheet1.Range("E2").FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF(Completed!$E:$E,$E2)"
    Sheet1.Range("E2").FormatConditions(Sheet1.Range("E2").FormatConditions.Count).SetFirstPriority
'
    With Sheet1.Range("E2").FormatConditions(1)
        .Interior.PatternColorIndex = xlAutomatic
        .Interior.Color = 65535
        .Interior.TintAndShade = 0
        .StopIfTrue = False
    End With
'
    Sheet1.Range("E2").Copy
    Sheet1.Range(Sheet1.Range("E2"), Sheet1.Range("E2").End(xlDown)).PasteSpecial paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
'
' CountToday Macro
    MsgBox Application.WorksheetFunction.CountIf(Sheets("Service Now Requests").Range("A:A"), Date) + _
            Application.WorksheetFunction.CountIf(Sheets("Toni Review").Range("A:A"), Date) & " Requests Added"

End Sub
Click to expand...
Thank you! I am getting the error: "Duplicate declaration in current scope" for this line: Dim c As Range,
 
Upvote 0
Ok. I relocated all 'Dim' to the top to solve that issue:

VBA Code: 
Sub exportV2()
'
    Dim cRow    As Long, LastRow    As Long, lr         As Long
    Dim ws1Row  As Long, ws2Row     As Long, ws3Row     As Long, x  As Long, i  As Long
    Dim c       As Range, TestRng   As Range, rCell     As Range                            ' <-- This variable (rCell) is not used (c is used)
    Dim arr()   As Variant
    Dim wb      As Workbook
    Dim ws1     As Worksheet, ws2   As Worksheet, ws3   As Worksheet
'
    For Each wb In Application.Workbooks
        If wb.Name Like "export*" Then
            wb.Activate
            Exit Sub
        End If
    Next wb
'
' paste Macro
    Cells.Copy ThisWorkbook.Sheets("Sheet1").Range("A1")
'
' Step1 Macro
    With ThisWorkbook.Sheets("Sheet1")
        .Range("A1").FormulaR1C1 = "Date"           ' <--- Don't need a formula for a string
        .Range("A2").FormulaR1C1 = "=TODAY()"
        .Range("A2").Copy
        .Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        .Range("A2").Copy .Range(.Range("A3"), .Range("A3").End(xlDown))
        .Range("B:C,H:I,L:M").Delete Shift:=xlToLeft
        .Columns("A:A").ColumnWidth = 10
        .Select
        .Range("A2").Select
    End With
'
' FullDelete Macro
    LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'
    With Worksheets("Sheet1").Range("B1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
        Do
            Set c = .Find(What:="*Full time*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
'
' IndDelete Macro
        LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
'
        Do
            Set c = .Find(What:="*Individual*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
'
' ResDelete Macro
        LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'
        Do
            Set c = .Find(What:="*Resiliency*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
    End With
'
' Step2 Macro
    Worksheets("Sheet1").Range(Worksheets("Sheet1").Rows("2:2"), Worksheets("Sheet1").Rows("2:2").End(xlDown)).Cut _
            Sheets("Service Now Requests").Range("A" & Rows.Count).End(xlUp).Offset(1)
'
' RemoveDups Macro
    Sheets("Service Now Requests").UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
'
' removeperiod Macro
    Sheets("Service Now Requests").Columns("F:F").Replace What:=".", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByColumns, _
            MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'
' vlook1 Macro
    lr = Sheets("Service Now Requests").Cells(Sheets("Service Now Requests").Rows.Count, "E").End(xlUp).Row       ' Find last row in column E with data
    Sheets("Service Now Requests").Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(""*""&RC[-6]&""*"", 'Projects'!C[-10]:C[-6], 5, FALSE)"   ' Insert formula
'
' vlook2 Macro
    Sheets("Service Now Requests").Select
    Range(Range("L2"), Range("L2").End(xlDown)).Copy
    Range("L2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("L8").Select
'
' moveRelocs Macro
    Set ws1 = Sheet1
    Set ws2 = Sheets("Completed")
    Set ws3 = Sheets("Toni Review")
'
'1. Move the other rows
    ws3Row = ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
    ws1Row = ws1.Cells(Rows.Count, 2).End(xlUp).Row
    x = Evaluate("Sum(COUNTIF(B2:B" & ws1Row & ",{""*Remove*"",""*Change *"",""*Relocat*""}))")
'
    If x = 0 Then
        MsgBox "No Remove, Change or Relocation records found"
        Exit Sub
    End If
'
    For Each c In ws1.Range("B2:B" & ws1Row)
        If c.Value Like "*Remove*" Or c.Value Like "*Change*" Or c.Value Like "*Relocation*" Then
            ReDim Preserve arr(i)
'
            arr(i) = c.Value
            i = i + 1
        End If
    Next c
'
    With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
        .AutoFilter 2, Array(arr), 7
        .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(ws3Row, 1)
        .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        .AutoFilter
        ws3.UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
    End With
'
' vlook3 Macro
    Sheet4.Activate
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(RC[-10],Sheet2!R1C1:R8C2, 2, FALSE)"
'
' Second_vlook2 Macro
    Range(Range("L2"), Range("L2").End(xlDown)).Copy
    Range("L2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("L8").Select
'
' Formating Macro
'This one compares column E on service now sheet to all of column E on the Completed Tab. Highlights any duplicates. (Would like this
'to also highlight any duplicates in column E on the Toni Review sheet when compared E on the completed tab also)
'
    Sheet1.Columns("E:E").FormatConditions.Delete
    Sheet1.Range("E2").FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF(Completed!$E:$E,$E2)"
    Sheet1.Range("E2").FormatConditions(Sheet1.Range("E2").FormatConditions.Count).SetFirstPriority
'
    With Sheet1.Range("E2").FormatConditions(1)
        .Interior.PatternColorIndex = xlAutomatic
        .Interior.Color = 65535
        .Interior.TintAndShade = 0
        .StopIfTrue = False
    End With
'
    Sheet1.Range("E2").Copy
    Sheet1.Range(Sheet1.Range("E2"), Sheet1.Range("E2").End(xlDown)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
'
' CountToday Macro
    MsgBox Application.WorksheetFunction.CountIf(Sheets("Service Now Requests").Range("A:A"), Date) + _
            Application.WorksheetFunction.CountIf(Sheets("Toni Review").Range("A:A"), Date) & " Requests Added"
End Sub
 
Upvote 0
At first it was bringing up the export worksheet but not moving forward. I removed the exit sub below and that moved it forward.
For Each wb In Application.Workbooks
If wb.Name Like "export*" Then
wb.Activate
Exit Sub
End If

Getting error of Select Method of worksheet class failed for .select below. Deleted the .select and it moved on.
Step1 Macro
With ThisWorkbook.Sheets("Sheet1")
.Range("A1").FormulaR1C1 = "Date" ' <--- Don't need a formula for a string
.Range("A2").FormulaR1C1 = "=TODAY()"
.Range("A2").Copy
.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
.Range("A2").Copy .Range(.Range("A3"), .Range("A3").End(xlDown))
.Range("B:C,H:I,L:M").Delete Shift:=xlToLeft
.Columns("A:A").ColumnWidth = 10
.Select
.Range("A2").Select

Getting error of subscript out of range for:
FullDelete Macro
LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).

Didn't have any luck fixing this one.
 
Upvote 0
Sorry the 'Exit Sub' issue was my fault, I didn't fix that from the original code you submitted. The other two errors you should not be getting.

Try the following that has the Exit sub issue corrected:

VBA Code: 
Sub exportV3()
'
    Dim cRow    As Long, LastRow    As Long, lr         As Long
    Dim ws1Row  As Long, ws2Row     As Long, ws3Row     As Long, x  As Long, i  As Long
    Dim c       As Range, TestRng   As Range, rCell     As Range                            ' <-- This variable (rCell) is not used (c is used)
    Dim arr()   As Variant
    Dim wb      As Workbook
    Dim ws1     As Worksheet, ws2   As Worksheet, ws3   As Worksheet
'
    For Each wb In Application.Workbooks
        If wb.Name Like "export*" Then
            wb.Activate
            Exit For
        End If
    Next wb
'
    If Not ActiveWorkbook.Name Like "export*" Then
        MsgBox "Workbook not found. Program will terminate."
        Exit Sub
    End If
'
' paste Macro
    Cells.Copy ThisWorkbook.Sheets("Sheet1").Range("A1")
'
' Step1 Macro
    With ThisWorkbook.Sheets("Sheet1")
        .Range("A1").FormulaR1C1 = "Date"           ' <--- Don't need a formula for a string
        .Range("A2").FormulaR1C1 = "=TODAY()"
        .Range("A2").Copy
        .Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        .Range("A2").Copy .Range(.Range("A3"), .Range("A3").End(xlDown))
        .Range("B:C,H:I,L:M").Delete Shift:=xlToLeft
        .Columns("A:A").ColumnWidth = 10
        .Select
        .Range("A2").Select
    End With
'
' FullDelete Macro
    LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'
    With Worksheets("Sheet1").Range("B1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
        Do
            Set c = .Find(What:="*Full time*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
'
' IndDelete Macro
        LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
'
        Do
            Set c = .Find(What:="*Individual*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
'
' ResDelete Macro
        LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'
        Do
            Set c = .Find(What:="*Resiliency*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
    End With
'
' Step2 Macro
    Worksheets("Sheet1").Range(Worksheets("Sheet1").Rows("2:2"), Worksheets("Sheet1").Rows("2:2").End(xlDown)).Cut _
            Sheets("Service Now Requests").Range("A" & Rows.Count).End(xlUp).Offset(1)
'
' RemoveDups Macro
    Sheets("Service Now Requests").UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
'
' removeperiod Macro
    Sheets("Service Now Requests").Columns("F:F").Replace What:=".", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByColumns, _
            MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'
' vlook1 Macro
    lr = Sheets("Service Now Requests").Cells(Sheets("Service Now Requests").Rows.Count, "E").End(xlUp).Row       ' Find last row in column E with data
    Sheets("Service Now Requests").Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(""*""&RC[-6]&""*"", 'Projects'!C[-10]:C[-6], 5, FALSE)"   ' Insert formula
'
' vlook2 Macro
    Sheets("Service Now Requests").Select
    Range(Range("L2"), Range("L2").End(xlDown)).Copy
    Range("L2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("L8").Select
'
' moveRelocs Macro
    Set ws1 = Sheet1
    Set ws2 = Sheets("Completed")
    Set ws3 = Sheets("Toni Review")
'
'1. Move the other rows
    ws3Row = ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
    ws1Row = ws1.Cells(Rows.Count, 2).End(xlUp).Row
    x = Evaluate("Sum(COUNTIF(B2:B" & ws1Row & ",{""*Remove*"",""*Change *"",""*Relocat*""}))")
'
    If x = 0 Then
        MsgBox "No Remove, Change or Relocation records found"
        Exit Sub
    End If
'
    For Each c In ws1.Range("B2:B" & ws1Row)
        If c.Value Like "*Remove*" Or c.Value Like "*Change*" Or c.Value Like "*Relocation*" Then
            ReDim Preserve arr(i)
'
            arr(i) = c.Value
            i = i + 1
        End If
    Next c
'
    With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
        .AutoFilter 2, Array(arr), 7
        .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(ws3Row, 1)
        .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        .AutoFilter
        ws3.UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
    End With
'
' vlook3 Macro
    Sheet4.Activate
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(RC[-10],Sheet2!R1C1:R8C2, 2, FALSE)"
'
' Second_vlook2 Macro
    Range(Range("L2"), Range("L2").End(xlDown)).Copy
    Range("L2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("L8").Select
'
' Formating Macro
'This one compares column E on service now sheet to all of column E on the Completed Tab. Highlights any duplicates. (Would like this
'to also highlight any duplicates in column E on the Toni Review sheet when compared E on the completed tab also)
'
    Sheet1.Columns("E:E").FormatConditions.Delete
    Sheet1.Range("E2").FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF(Completed!$E:$E,$E2)"
    Sheet1.Range("E2").FormatConditions(Sheet1.Range("E2").FormatConditions.Count).SetFirstPriority
'
    With Sheet1.Range("E2").FormatConditions(1)
        .Interior.PatternColorIndex = xlAutomatic
        .Interior.Color = 65535
        .Interior.TintAndShade = 0
        .StopIfTrue = False
    End With
'
    Sheet1.Range("E2").Copy
    Sheet1.Range(Sheet1.Range("E2"), Sheet1.Range("E2").End(xlDown)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
'
' CountToday Macro
    MsgBox Application.WorksheetFunction.CountIf(Sheets("Service Now Requests").Range("A:A"), Date) + _
            Application.WorksheetFunction.CountIf(Sheets("Toni Review").Range("A:A"), Date) & " Requests Added"
End Sub
 
Upvote 0
johnnyL said:
Sorry the 'Exit Sub' issue was my fault, I didn't fix that from the original code you submitted. The other two errors you should not be getting.

Try the following that has the Exit sub issue corrected:

VBA Code: 
Sub exportV3()
'
    Dim cRow    As Long, LastRow    As Long, lr         As Long
    Dim ws1Row  As Long, ws2Row     As Long, ws3Row     As Long, x  As Long, i  As Long
    Dim c       As Range, TestRng   As Range, rCell     As Range                            ' <-- This variable (rCell) is not used (c is used)
    Dim arr()   As Variant
    Dim wb      As Workbook
    Dim ws1     As Worksheet, ws2   As Worksheet, ws3   As Worksheet
'
    For Each wb In Application.Workbooks
        If wb.Name Like "export*" Then
            wb.Activate
            Exit For
        End If
    Next wb
'
    If Not ActiveWorkbook.Name Like "export*" Then
        MsgBox "Workbook not found. Program will terminate."
        Exit Sub
    End If
'
' paste Macro
    Cells.Copy ThisWorkbook.Sheets("Sheet1").Range("A1")
'
' Step1 Macro
    With ThisWorkbook.Sheets("Sheet1")
        .Range("A1").FormulaR1C1 = "Date"           ' <--- Don't need a formula for a string
        .Range("A2").FormulaR1C1 = "=TODAY()"
        .Range("A2").Copy
        .Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        .Range("A2").Copy .Range(.Range("A3"), .Range("A3").End(xlDown))
        .Range("B:C,H:I,L:M").Delete Shift:=xlToLeft
        .Columns("A:A").ColumnWidth = 10
        .Select
        .Range("A2").Select
    End With
'
' FullDelete Macro
    LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'
    With Worksheets("Sheet1").Range("B1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
        Do
            Set c = .Find(What:="*Full time*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
'
' IndDelete Macro
        LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
'
        Do
            Set c = .Find(What:="*Individual*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
'
' ResDelete Macro
        LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'
        Do
            Set c = .Find(What:="*Resiliency*", After:=[B1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns _
                    , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                cRow = c.Row
                c.EntireRow.Delete
            End If
        Loop While Not c Is Nothing And cRow < LastRow
    End With
'
' Step2 Macro
    Worksheets("Sheet1").Range(Worksheets("Sheet1").Rows("2:2"), Worksheets("Sheet1").Rows("2:2").End(xlDown)).Cut _
            Sheets("Service Now Requests").Range("A" & Rows.Count).End(xlUp).Offset(1)
'
' RemoveDups Macro
    Sheets("Service Now Requests").UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
'
' removeperiod Macro
    Sheets("Service Now Requests").Columns("F:F").Replace What:=".", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByColumns, _
            MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'
' vlook1 Macro
    lr = Sheets("Service Now Requests").Cells(Sheets("Service Now Requests").Rows.Count, "E").End(xlUp).Row       ' Find last row in column E with data
    Sheets("Service Now Requests").Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(""*""&RC[-6]&""*"", 'Projects'!C[-10]:C[-6], 5, FALSE)"   ' Insert formula
'
' vlook2 Macro
    Sheets("Service Now Requests").Select
    Range(Range("L2"), Range("L2").End(xlDown)).Copy
    Range("L2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("L8").Select
'
' moveRelocs Macro
    Set ws1 = Sheet1
    Set ws2 = Sheets("Completed")
    Set ws3 = Sheets("Toni Review")
'
'1. Move the other rows
    ws3Row = ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
    ws1Row = ws1.Cells(Rows.Count, 2).End(xlUp).Row
    x = Evaluate("Sum(COUNTIF(B2:B" & ws1Row & ",{""*Remove*"",""*Change *"",""*Relocat*""}))")
'
    If x = 0 Then
        MsgBox "No Remove, Change or Relocation records found"
        Exit Sub
    End If
'
    For Each c In ws1.Range("B2:B" & ws1Row)
        If c.Value Like "*Remove*" Or c.Value Like "*Change*" Or c.Value Like "*Relocation*" Then
            ReDim Preserve arr(i)
'
            arr(i) = c.Value
            i = i + 1
        End If
    Next c
'
    With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
        .AutoFilter 2, Array(arr), 7
        .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(ws3Row, 1)
        .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        .AutoFilter
        ws3.UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes
    End With
'
' vlook3 Macro
    Sheet4.Activate
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    Range("L2:L" & lr).FormulaR1C1 = "=VLOOKUP(RC[-10],Sheet2!R1C1:R8C2, 2, FALSE)"
'
' Second_vlook2 Macro
    Range(Range("L2"), Range("L2").End(xlDown)).Copy
    Range("L2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("L8").Select
'
' Formating Macro
'This one compares column E on service now sheet to all of column E on the Completed Tab. Highlights any duplicates. (Would like this
'to also highlight any duplicates in column E on the Toni Review sheet when compared E on the completed tab also)
'
    Sheet1.Columns("E:E").FormatConditions.Delete
    Sheet1.Range("E2").FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF(Completed!$E:$E,$E2)"
    Sheet1.Range("E2").FormatConditions(Sheet1.Range("E2").FormatConditions.Count).SetFirstPriority
'
    With Sheet1.Range("E2").FormatConditions(1)
        .Interior.PatternColorIndex = xlAutomatic
        .Interior.Color = 65535
        .Interior.TintAndShade = 0
        .StopIfTrue = False
    End With
'
    Sheet1.Range("E2").Copy
    Sheet1.Range(Sheet1.Range("E2"), Sheet1.Range("E2").End(xlDown)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
'
' CountToday Macro
    MsgBox Application.WorksheetFunction.CountIf(Sheets("Service Now Requests").Range("A:A"), Date) + _
            Application.WorksheetFunction.CountIf(Sheets("Toni Review").Range("A:A"), Date) & " Requests Added"
End Sub
Click to expand...
Hmm still getting the same two errors.
 
Upvote 0
Change:
VBA Code: 
' Step1 Macro
    With ThisWorkbook.Sheets("Sheet1")

to:
VBA Code: 
' Step1 Macro
    ThisWorkbook.Activate
'
    With ThisWorkbook.Sheets("Sheet1")
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

I
  • Question
Current Code taking 10 Hours to run. Need Help to Optimize
Replies
5
Views
256
ItalianPlatinum
I
S
  • Question
VBA Code - Create Log sheet (Errorlog) in case VBA Macro condition is not met
Replies
1
Views
134
Tupe77
T
B
  • Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
211
B-radK
B
D
  • Question
VBA optimization advice
Replies
3
Views
95
bobsan42
bobsan42
S
  • Solved
Import csv file and append to existing table?
Replies
5
Views
622
shellp
S

Forum statistics

Threads
1,214,919
Messages
6,122,259
Members
449,075
Latest member
staticfluids

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