I am getting an error when I copy this macro to different worksheets in the same workbook.
For Example, when I copy this code for the worksheet "Class 11" and rename it to "Class 16" by doing a find and replace all from Class 11 to Class 16 and paste it in the vba, and do this for all the worksheets, so "Class 16", "Class 81", etc. I get an error that the macro is too long.
I want the macro to do the same thing but over the course of 71 worksheets in the same workbook and doing vlookups to over 71 worksheets in a different workbook.
Sub MonthlySKUAudit()
'
' MonthlySKUAudit Macro
'
'
'Class 11'
Sheets("Class 11").Select
Columns("W:W").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("W1").Select
ActiveCell.FormulaR1C1 = "Service Code"
Range("W1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("W2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,13,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("W2").AutoFill Destination:=Range("W2:W" & lastrow)
Columns("W:W").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("V:W").Select
Range("W1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("W1").Select
Columns("X:X").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("X1").Select
ActiveCell.FormulaR1C1 = "Return Program"
Range("X1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("X2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,4,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("X2").AutoFill Destination:=Range("X2:X" & lastrow)
Columns("X:X").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AA:AA").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AA1").Select
ActiveCell.FormulaR1C1 = "Openbox Return"
Range("AA1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AA2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,9,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("AA2").AutoFill Destination:=Range("AA2:AA" & lastrow)
Columns("AA:AA").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AE:AE").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AE1").Select
ActiveCell.FormulaR1C1 = "Func Check"
Range("AE1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AE2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,10,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("AE2").AutoFill Destination:=Range("AE2:AE" & lastrow)
Columns("AE:AE").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AG:AG").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AG1").Select
ActiveCell.FormulaR1C1 = "Serial Number"
Range("AG1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AG2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,11,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("AG2").AutoFill Destination:=Range("AG2:AG" & lastrow)
Columns("AG:AG").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("Y:Y").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("Y1").Select
ActiveCell.FormulaR1C1 = "Known Restrictions"
Range("Y1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("Y2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,7,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("Y2").AutoFill Destination:=Range("Y2:Y" & lastrow)
Columns("Y:Y").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AK:AK").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AK1").Select
ActiveCell.FormulaR1C1 = "Support Factory Warranty"
Range("AK1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AK2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,15,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("AK2").AutoFill Destination:=Range("AK2:AK" & lastrow)
Columns("AK:AK").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AM:AM").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AM1").Select
ActiveCell.FormulaR1C1 = "Service Under Warranty"
Range("AM1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AM2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,16,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("AM2").AutoFill Destination:=Range("AM2:AM" & lastrow)
Columns("AM:AM").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AO:AO").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AO1").Select
ActiveCell.FormulaR1C1 = "Service Outside Warranty"
Range("AO1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AO2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,17,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("AO2").AutoFill Destination:=Range("AO2:AO" & lastrow)
Columns("AO:AO").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR1").Select
ActiveCell.FormulaR1C1 = "Resell Indicator"
Range("AR1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AR2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,21,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("AR2").AutoFill Destination:=Range("AR2:AR" & lastrow)
Columns("AR:AR").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AU:AU").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AU1").Select
ActiveCell.FormulaR1C1 = "RTV Defective Days"
Range("AU1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AU2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,20,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("AU2").AutoFill Destination:=Range("AU2:AU" & lastrow)
Columns("AU:AU").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AW:AW").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AW1").Select
ActiveCell.FormulaR1C1 = "RTV Open Box Days"
Range("AW1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AW2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,19,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("AW2").AutoFill Destination:=Range("AW2:AW" & lastrow)
Columns("AW:AW").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AY:AY").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AY1").Select
ActiveCell.FormulaR1C1 = "Open Box Resell"
Range("AY1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AY2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,22,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("AY2").AutoFill Destination:=Range("AY2:AY" & lastrow)
Columns("AY:AY").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("BB:BB").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("BB1").Select
ActiveCell.FormulaR1C1 = "Liquidation"
Range("BB1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("BB2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,24,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("BB2").AutoFill Destination:=Range("BB2:BB" & lastrow)
Columns("BB:BB").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("BE:BE").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("BE1").Select
ActiveCell.FormulaR1C1 = "Shelf Display to OB Resell"
Range("BE1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("BE2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,23,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("BE2").AutoFill Destination:=Range("BE2:BE" & lastrow)
Columns("BE:BE").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AA:AB").Select
Range("AB1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AB1").Select
Columns("AE:AF").Select
Range("AF1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AF1").Select
Columns("AG:AH").Select
Range("AH1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AH1").Select
Columns("AJ:AK").Select
Range("AK1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AK1").Select
Columns("AL:AM").Select
Range("AM1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AM1").Select
Columns("AN:AO").Select
Range("AO1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AO1").Select
Columns("AQ:AR").Select
Range("AR1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AR1").Select
Columns("AT:AU").Select
Range("AU1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AU1").Select
Columns("AV:AW").Select
Range("AW1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AW1").Select
Columns("AX:AY").Select
Range("AY1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AY1").Select
Columns("BA:BB").Select
Range("BB1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("BB1").Select
Columns("BD:BE").Select
Range("BE1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("BE1").Select
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("AA:AA").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AA1").Select
ActiveCell.FormulaR1C1 = "Returnable"
Range("AA1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AA2").Formula = "=VLOOKUP(E2,'[Return Disposition Reference.xlsx]ence.xlsx]Class 11'!$D:$AD,8,False)"
lastrow = Range("A65536").End(xlUp).Row
Range("AA2").AutoFill Destination:=Range("AA2:AA" & lastrow)
Columns("AA:AA").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("Z:AA").Select
Range("AA1").Activate
Selection.RowDifferences(ActiveCell).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("AA1").Select
End Sub
When doing the same thing over and over you want to do a loop. In this case I would do a For Each loop.
Also you want to avoid using .Select. See HERE for a great explanation of how to do this.
Combing the two I redid the first part of your code, column W:
Sub monthlyskuaudit()
Dim ws As Worksheet
Dim lastRow As Long
Dim cel As Range
Dim diffRng As Range
For Each ws In ActiveWorkbook.Sheets
With ws
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns("W:W").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
With .Range("W1")
.Value = "Service Code"
.Interior.Color = 65535
End With
For Each cel In .Range("W2:W" & lastRow)
cel.Value = ws.Evaluate("=VLOOKUP(E" & cel.Row & ",'V:\Return Disposition Reference\[Return Disposition Reference.xlsx]"& ws.Name & "'!$D:$AD,13,False)")
Next cel
Set diffRng = .Columns("V:W").RowDifferences(.Range("W1"))
diffRng.Interior.Color = 5287936
'...
End With
Next ws
End Sub
This will iterate through each sheet and do the same thing over and over. Try to do the rest on your own. If you come into a specific problem come back with a more specific question.
Loops are your friend
You have many sequential processes where only one to three factors differ between up to sixteen repeated command sections.
Construct an array of the variables that change from one iteration to another and loop through the array, passing a new set of vars into the basic commands with each pass. This can be done to loop through worksheets, columns on a worksheet or even individual cells. The scope of each loop through an array is dictated by the LBound and UBound functions.
Essentially, I've broken your long-winded, step-by-step process down to a few loops. I've also broken out primary areas of concern into three sub procedures to localize them for individual attention.
1. main - Creates an array of the worksheet names to be processed and loops through the names, passing each in turn into the monthlySKUAudit as a parameter.
2. monthlySKUAudit - Takes the worksheet name passed to it and processes an individual worksheet by looping through arrays of columns and column-specific information.
3. makeLookGood - Moves some redundant formatting code to a 'helper' sub where minor inflections between uses are passed in as parameters.
Sub main()
'main - loop through an array of worksheets and call monthlySKUAudit for each one
Dim w As Long, vWSs As Variant
'assign an array of worksheet names
vWSs = Array("Class 11", "Class 16", "Class 81")
For w = LBound(vWSs) To UBound(vWSs)
Call monthlySKUAudit(strWS:=CStr(vWSs(w)))
Next w
End Sub
Sub monthlySKUAudit(strWS As String)
'monthlySKUAudit Macro - column/formula/insert/value and RowDifferences
Dim rws As Long
Dim c As Long, vCOLs As Variant
With Worksheets(strWS)
rws = .Cells(Rows.Count, 1).End(xlUp).Row - 1
'form of <numerical column>, <vlookup return column>, <row 1 title>
vCOLs = Array(Columns("W:W").Column, 13, "Service Code", _
Columns("X:X").Column, 4, "Return Program", _
Columns("AA:AA").Column, 9, "Openbox Return", _
Columns("AE:AE").Column, 10, "Func Check", _
Columns("AG:AG").Column, 11, "Serial Number", _
Columns("Y:Y").Column, 7, "Known Restrictions", _
Columns("AK:AK").Column, 15, "Support Factory Warranty", _
Columns("AM:AM").Column, 16, "Service Under Warranty", _
Columns("AO:AO").Column, 17, "Service Outside Warranty", _
Columns("AR:AR").Column, 21, "Resell Indicator", _
Columns("AU:AU").Column, 20, "RTV Defective Days", _
Columns("AW:AW").Column, 19, "RTV Open Box Days", _
Columns("AY:AY").Column, 22, "Open Box Resell", _
Columns("BB:BB").Column, 24, "Liquidation", _
Columns("BE:BE").Column, 23, "Shelf Display to OB Resell")
'process the column inserts, yellow fill and row 1 column header labels
For c = LBound(vCOLs) To UBound(vCOLs) Step 3
.Columns(vCOLs(c)).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
With .Columns(vCOLs(c))
Call makeLookGood(.Cells(1), 65535, vCOLs(c + 2))
.Cells(2).Resize(rws, 1).Formula = _
"=VLOOKUP(E2, '[Return Disposition Reference.xlsx]" & strWS & "'!$D:$AD, " & vCOLs(c + 1) & ", FALSE)"
.Cells(2).Resize(rws, 1) = .Cells(2).Resize(rws, 1).Value
End With
Next c
'form of <string columns>
vCOLs = Array("V:W", "AA:AB", "AE:AF", "AG:AH", "AJ:AK", "AL:AM", _
"AN:AO", "AQ:AR", "AT:AU", "AV:AW", "AX:AY", "BA:BC", _
"BD:BE")
'process all of the RowDifferences highlights
For c = LBound(vCOLs) To UBound(vCOLs)
With .Columns(vCOLs(c))
Call makeLookGood(.Cells.RowDifferences(.Cells(1, 2)), 5287936)
End With
Next c
'header row formatting
With .Rows("1:1")
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'finish the oddball Insert & Formula left at the bottom
.Columns("AA:AA").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
With .Columns("AA:AA")
Call makeLookGood(.Cells(1), 65535, "Returnable")
.Cells(2).Resize(rws, 1).Formula = _
"=VLOOKUP(E2, '[Return Disposition Reference.xlsx]" & strWS & "'!$D:$AD, 8, FALSE)"
.Cells(2).Resize(rws, 1) = .Cells(2).Resize(rws, 1).Value
End With
'finish the oddball RowDifferences left at the bottom
With .Columns("Z:AA")
Call makeLookGood(.Cells.RowDifferences(.Cells(1, 2)), 5287936)
End With
End With
End Sub
Sub makeLookGood(rng As Range, clr As Long, Optional lbl As Variant = "")
'makeLookGood - interior fill and optional column header label
With rng
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = clr
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'if a column header label was passed in, use it
If CBool(Len(CStr(lbl))) Then _
.Cells(1) = lbl
End With
End Sub
I am concerned with two areas but I did not change anything out of the order that you had originally. When inserting columns, it is best to work from right-to-left so that an inserted column does not change the order of subsequent column insertions. You can work left-to-right but you have to be careful to compensate for the fact that after inserting a column, you adjust subsequent work for the shift.
In at least two places, you start working in one direction and then stop and backtrack. Having never seen the actual data I cannot make definitive statements as you may have to backtrack in order to take advantage of recalculated data but in general it is better to work from one direction to another or base all column selection on the relative position of column header labels that do not change no matter what ordinal position they are in.
Your variable declarations¹ were lacking. Declare your variables as distinct types and assign them appropriate values.
I've also completely removed your reliance on .Select² and Activate² as a method of referencing cells while making good use of the With ... End With statement to facilitate direct worksheet/column/cell referencing. The ActiveWorkbook, ActiveSheet and ActiveCell properties are simply just not reliable methods of referencing an object to perform work on.
All-in-all, it didn't boil all the way down to a handful of code lines but it is certainly shorter (and to my eye more readable) than the original. An added bonus is that additions, deletions and modifications are performed once in a central location, not in dozens of virtually identical locales.
¹ Setting Require Variable Declaration within the VBE's Tools ► Options ► Editor property page will put the Option Explicit statement at the top of each newly created code sheet. This will avoid silly coding mistakes like misspellings as well as influencing you to use the correct variable type in the variable declaration. Variables created on-the-fly without declaration are all of the variant/object type. Using Option Explicit is widely considered 'best practice'.
² See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
Related
I have a code that I want to run several times but for now I can run it only once unless I made some changes at data sheet name.
My code:
Public Sub MyFilter()
Dim lngStart As Date, lngEnd As Date
lngStart = Range("b2").Value 'assume this is the start date
lngEnd = Range("b3").Value 'assume this is the end date
Range("q:q").AutoFilter field:=1, _
Criteria1:=">=" & lngStart, _
Operator:=xlAnd, _
Criteria2:="<=" & lngEnd
Range("A1:s3000").Select
Range("A:A").Activate
Selection.Copy
Sheets.Add After:=ActiveSheet
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "FilterData"
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:A").EntireColumn.AutoFit
Cells.Select
Cells.EntireColumn.AutoFit
Rows("1:1").Select
Application.CutCopyMode = False
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.AutoFilter
Columns("A:A").EntireColumn.AutoFit
Range("A2").Select
End Sub
Before I execute it I create sheet2 manually but if I want to run it again I cant because I already have "FilterData" sheet data name.
How can I modify the code to:
1. Run it without the need to enter "sheet2" manually.
2. To run it more than once.
Thanks!
When you create a new sheet in Excel it becomes the active sheet, so instead of specifically selecting sheet 2 you can use activesheet
Sheets.Add After:=ActiveSheet
With ActiveSheet
.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Columns("A:A").EntireColumn.AutoFit
.Cells.Select
.Cells.EntireColumn.AutoFit
.Rows("1:1").Select
.Application.CutCopyMode = False
With Selection
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.AutoFilter
End With
.Columns("A:A").EntireColumn.AutoFit
.Range("A2").Select
End With
Then you can manually rename all your new sheets.
Alternatively if you want to loop a set number of times you could wrap the whole thing in a loop and increment sheet names:
For i = 1 to 4
Sheets.Add After:=ActiveSheet
With ActiveSheet
.Name = "FilterData " & i
*rest of the code here*
End With
Next i
This will create 4 sheets called FilterData 1, 2, 3 etc, but again this will throw an error if you already have sheets called those things.
I'm an excel vba noob and I'm quite stuck at this code wherein I need to format cells containing a specific criteria for multiple columns.
For example I would need to highlight all values except the cells which contains "Complete" into YELLOW with BOLD RED FONT.
I've tried to just record it by simply filtering out "Complete" and highlighting all other values but I would need it to be dynamic.
Sub Macro1()
ActiveSheet.Range("$A$1:$W$6114").AutoFilter Field:=6, Criteria1:= _
"=Incomplete", Operator:=xlOr, Criteria2:="="
Range("F171").Select
Range(Selection, Selection.End(xlDown)).Select
Range("F171:F6114").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
End Sub
Will be grateful for any assistance!
Try this:
Sub Macro1()
Dim rng As Range
Set rng = ActiveSheet.Range("A1").CurrentRegion
With rng
.AutoFilter Field:=6, Criteria1:="<>Complete", Operator:=xlAnd
End With
With rng.Range(Cells(2, 6), Cells(rng.Rows.Count, 6)).SpecialCells(xlCellTypeVisible)
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = vbYellow
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With .Font
.Color = vbRed
.TintAndShade = 0
.Bold = True
End With
End With
End Sub
my first button (Schaltfläche 83)
Other button which I want to activate vom "Hirata Bestellformular"
1st option: the top blue one
2nd option: the big one (activexelement)
I want to activate one button from another worksheet because I want to execute the code below on the worksheet "Teileliste" directly from "Hirata Bestellformular". How can I accomplish this?
Sub Teileliste_generieren()
' advanced filter
Sheets("Hirata Bestellformular").Range("Tabelle3[[#Headers],[#Data]]"). _
AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("B50:B51"), _
CopyToRange:=Range("B54:B55"), Unique:=False
Range("B5").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(LEFT(R[50]C,FIND(CHAR(10),R[50]C)-1),R[50]C)"
Range("B6").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(LEFT(R[50]C,FIND(CHAR(10),R[50]C)-1),R[50]C)"
Range("B5:B6").Select
Selection.AutoFill Destination:=Range("B5:B26"), Type:=xlFillDefault
Range("B5:B26").Select
Range("D22").Select
'formatierung tabelle
Range("B3").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16763955
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternThemeColor = xlThemeColorAccent3
.Color = 16777215
.TintAndShade = 0
.PatternTintAndShade = 0.799981688894314
End With
Range("B5").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 9868950
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B6").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15395562
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B5:B6").Select
Selection.AutoFill Destination:=Range("B5:B26"), Type:=xlFillDefault
Range("B5:B26").Select
Range("D20").Select
' Wenn 0 blank
Range("B5:B26").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("C22").Select
' Exportieren
ThisWorkbook.Sheets("Teileliste").Copy
Application.GetSaveAsFilename
End Sub
I can try. :)
If I understand you, you want to be able to press Teileliste generieren from Hirata Bestellformular. This means that you still want the button Schaltfläche 83 do to the same thing as Teileliste generieren, but you don't want to switch sheets to press the button?
Then I believe your problem is in your Range.Select statements.
In Excels VBA Object Model, if you call Range("B50:B51").Select from the Teileliste-sheet, then it will automatically select that range in Teileliste-sheet. If do it from Hirata Bestellformular, then it will select Range("B50:B51") from Hirata Bestellformular instead.
This means: it should work if you change all your Range("...").Select to Worksheets("Teileliste").Range("...").Select
This has to do with the Excel VBA Object Model.
I'm pretty sure that should do the trick but it depends on where your code is placed (within the specific sheets or in a Module). Try replacing the Range.Selects and see if it helps. :)
Just A quick hint:
You can right-click the button Schaltfläche 83 and assign a macro to it. So in your case you can just right-click -> assign macro -> choose
Teileliste_generieren()
If your code can deal with being called on different sheets, then it Will work.
//from My iPhone
Sub Teileliste_generieren2()
' advanced filter
Sheets("Hirata Bestellformular").Range("Tabelle3[[#Headers],[#Data]]"). _
AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Worksheets("Teileliste").Range("B50:B51"), _
CopyToRange:=Worksheets("Teileliste").Range("B54:B55"), Unique:=False
Worksheets("Teileliste").Range("B5").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(LEFT(R[50]C,FIND(CHAR(10),R[50]C)-1),R[50]C)"
Worksheets("Teileliste").Range("B6").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(LEFT(R[50]C,FIND(CHAR(10),R[50]C)-1),R[50]C)"
Worksheets("Teileliste").Range("B5:B6").Select
Selection.AutoFill Destination:=Worksheets("Teileliste").Range("B5:B26"), Type:=xlFillDefault
Worksheets("Teileliste").Range("B5:B26").Select
Worksheets("Teileliste").Range("D22").Select
'formatierung tabelle
Worksheets("Teileliste").Range("B5").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Worksheets("Teileliste").Range("B6").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Worksheets("Teileliste").Range("B5:B6").Select
Selection.AutoFill Destination:=Worksheets("Teileliste").Range("B5:B26"), Type:=xlFillDefault
Worksheets("Teileliste").Range("B5:B26").Select
Worksheets("Teileliste").Range("C18").Select
' Wenn 0 blank
Worksheets("Teileliste").Range("B5:B26").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Worksheets("Teileliste").Range("C22").Select
' Exportieren
ThisWorkbook.Sheets("Teileliste").Copy
Application.GetSaveAsFilename
End Sub
I just replaced it everywhere like you said and it works if I aktivate the makro from "Teileliste" but there s error when I acctivate it from "Hiraa Bestellformular" saying: Error1004 he Select- Method of the Range-Object could not be executed:/ Another suggestion?:)
The code: a commandutton code with two parts, The first part of it sort the cells, and second part is recoloring the sorted cells.
The problem: the macro exit after the first, without doing the recoloring. If I commented the first part, the code does the recoloring.
Any idea, what could be the problem?
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim i As Integer
Dim WName As String
''First Part
WName = ActiveWorkbook.ActiveSheet.Name
Range("B2:B21").Select
ActiveWorkbook.Worksheets(WName).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(WName).Sort.SortFields.Add Key:=Range("B2:B21"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(WName).Sort
.SetRange Range("B2:B21")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
''Second Part
For i = 2 To 21
If i Mod 2 = 0 Then
Cells(i, 2).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Else
Cells(i, 2).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
End If
Next i
End Sub
I'm new to vba and struggling with a macro.
I have recorded a macro and then tried to adapt it.
What I have is a list of drivers as headers currently c1:t1 but as I add or remove drivers I need the selection below to adapt.
B2 is a merged cell (B2:B5) with the date in and the columns across are still individual cells.
The date is repeated all the way down in the same format for each day of the year.
What i'm trying to do is select a date and press ctrl+q and copy the list of drivers names across the headers to a new sheet in column A and the selected date and the number of columns to match the number of drivers in the header.
Sub Macro6()
'
' Macro6 Macro
'
' Keyboard Shortcut: Ctrl+q
'
Selection.Copy
Sheets("Daily").Select
Range("C4:F4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Sheets("Weekly").Select
Range("c1", Range("CV1").End(xlToLeft)).Select
Selection.Copy
Sheets("Daily").Select
Range("A5").Select
ActiveWindow.SmallScroll Down:=-27
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Sheets("Weekly").Select
Application.CutCopyMode = False
Sheets("Daily").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Selection.ClearContents
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.ClearComments
Sheets("Weekly").Select
Application.CutCopyMode = False
End Sub
Dim lCol As Long, cpycel As Range
Set cpycel = Range(ActiveCell.Address)
lCol = (Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column) - 1
cpycel.Resize(4, lCol).Select
Selection.Copy
Sheets("Daily").Select
Range("C4:F4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Sheets("Weekly").Select
Range(Cells(1, 2), Cells(1, (lCol + 1))).Select
Selection.Copy
Sheets("Daily").Select
Range("a4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Range(Cells(5, 1), Cells((lCol + 3), 6)).Select