Excel VBA Loop? - vba

I am new to creating VBA macros. I recorded the macro below, but I need this done for 18 other worksheets in the workbook. I do not know how to create a loop. Can it be done from this recorded macro? Sorry for the long code. Again this code is used on 18 other worksheets and am unsure how to create a loop.
Sheets("C3 CONW INW OPIS_CMA").Select
Range("G1").Select
ActiveCell.FormulaR1C1 = "PSTRIK"
Range("A1").Select
ActiveCell.FormulaR1C1 = "PRECID"
Range("A2").Select
ActiveCell.FormulaR1C1 = "P"
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A26"), Type:=xlFillDefault
Range("A2:A26").Select
Range("C1").Select
ActiveCell.FormulaR1C1 = "PEXCH"
Range("C2").Select
ActiveCell.FormulaR1C1 = "7"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C26"), Type:=xlFillDefault
Range("C2:C26").Select
Columns("O:O").Select
Selection.Delete Shift:=xlToLeft
Columns("N:N").Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Cut
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Columns("I:I").Select
Selection.Cut
Columns("K:K").Select
Selection.Insert Shift:=xlToRight
Range("I1").Select
ActiveCell.FormulaR1C1 = "PQTY"
Range("G1").Select
ActiveCell.FormulaR1C1 = "PCTYM"
Range("D1").Select
ActiveCell.FormulaR1C1 = "PFC"
Range("B1").Select
ActiveCell.FormulaR1C1 = "PACCT"
Range("J1").Select
ActiveCell.FormulaR1C1 = "PPRTCP"
Range("E1").Select
ActiveCell.FormulaR1C1 = "PSUBTY"
Range("H1").Select
ActiveCell.FormulaR1C1 = "PSBUS"
Range("H2").Select
ActiveCell.FormulaR1C1 = "0"
Selection.AutoFill Destination:=Range("H2:H23"), Type:=xlFillDefault
Range("H2:H23").Select
Columns("I:I").Select
Range("I240").Activate
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("I1").Select
ActiveCell.FormulaR1C1 = "PBS"
Range("I2").Select
ActiveCell.FormulaR1C1 = "1"
Selection.AutoFill Destination:=Range("I2:I23"), Type:=xlFillDefault
Range("I2:I23").Select
Again sorry for the format of the code.

I cleaned up your code a bit, and put it into a sub which takes a worksheet as its argument. I then made another sub which loops through all the worksheets of the workbook the code resides in, and makes the changes specified.
Option Explicit
Sub test()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Call fix_stuff_in_the_sheet(ws)
Next ws
End Sub
Sub fix_stuff_in_the_sheet(ws As Worksheet)
ws.Range("G1").FormulaR1C1 = "PSTRIK"
ws.Range("A1").FormulaR1C1 = "PRECID"
ws.Range("A2").FormulaR1C1 = "P"
ws.Range("A2").AutoFill Destination:=Range("A2:A26"), Type:=xlFillDefault
ws.Range("A2:A26").FormulaR1C1 = "PEXCH"
ws.Range("C2").FormulaR1C1 = "7"
ws.Range("C2").AutoFill Destination:=Range("C2:C26"), Type:=xlFillDefault
ws.Columns("N:O").Delete Shift:=xlToLeft
ws.Columns("E:E").Delete Shift:=xlToLeft
ws.Columns("J:J").Delete Shift:=xlToLeft
ws.Columns("D:D").Delete Shift:=xlToLeft
ws.Columns("E:E").Cut
ws.Columns("G:G").Insert Shift:=xlToRight
ws.Columns("I:I").Cut
ws.Columns("K:K").Insert Shift:=xlToRight
ws.Range("I1").FormulaR1C1 = "PQTY"
ws.Range("G1").FormulaR1C1 = "PCTYM"
ws.Range("D1").FormulaR1C1 = "PFC"
ws.Range("B1").FormulaR1C1 = "PACCT"
ws.Range("J1").FormulaR1C1 = "PPRTCP"
ws.Range("E1").FormulaR1C1 = "PSUBTY"
ws.Range("H1").FormulaR1C1 = "PSBUS"
ws.Range("H2").FormulaR1C1 = "0"
ws.Range("H2").AutoFill Destination:=Range("H2:H23"), Type:=xlFillDefault
ws.Range("I240").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ws.Range("I1").FormulaR1C1 = "PBS"
ws.Range("I2").FormulaR1C1 = "1"
ws.Range("I2").AutoFill Destination:=Range("I2:I23"), Type:=xlFillDefault
End Sub
If you don't want the code to be performed on all the sheets in your workbook, you need to figure out a way for the first function to only be called with the sheets you want as an argument.
There is still some superfluous code in the subs I post here, e.g. you first autofill range A2:A26 with the letter P, but then later overwrites that with PEXCH. I'll leave it to you to weed out this though.

Related

Macro to Auto Fill Down to last adjacent cells

I want my macro to populate my formulas all the way down the sheet. Every time I run the macro it stops at row 13662 because that was the last row when I was recording it, but the last row changes constantly. Is there a way to do this?
The columns I need to do this for are N, I, J, K, and L. Any help appreciated. See code below.
Sub Weekly_Expiring_Rebate_Report()
'
' Weekly_Expiring_Rebate_Report Macro
'
'
Columns("A:A").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:A").Select
Range(Selection, Selection.End(xlToRight)).Select
Columns("A:Z").EntireColumn.AutoFit
Columns("N:N").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.NumberFormat = "General"
Range("N1").Select
ActiveCell.FormulaR1C1 = "Expiring Rebate Status"
Range("N2").Select
Columns("N:N").EntireColumn.AutoFit
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'Status IND'!C[-13]:C[-11],3,FALSE)"
Range("N2").Select
Selection.AutoFill Destination:=Range("N2:N13662")
Range("N2:N13662").Select
Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("I2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],4)"
Range("I2").Select
Selection.AutoFill Destination:=Range("I2:I13662")
Range("I2:I13662").Select
Range("J2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-2],6)"
Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J13662")
Range("J2:J13662").Select
Range("K2").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-1],2)"
Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K13662")
Range("K2:K13662").Select
Range("L2").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-4],2)"
Range("L2").Select
Selection.AutoFill Destination:=Range("L2:L13662")
Range("L2:L13662").Select
Range("I1").Select
ActiveCell.FormulaR1C1 = "EXP_YEAR"
Range("K1").Select
ActiveCell.FormulaR1C1 = "EXP_MONTH"
Range("L1").Select
ActiveCell.FormulaR1C1 = "EXP_DAY"
Columns("I:L").Select
Range("L1").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("J:J").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("L1").Select
ActiveCell.FormulaR1C1 = "EXP_Month_Name"
Columns("I:L").Select
Range("L1").Activate
Columns("I:L").EntireColumn.AutoFit
Range("L2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],Month!C[-11]:C[-10],2,FALSE)"
Range("L2").Select
Selection.AutoFill Destination:=Range("L2:L13662")
Range("L2:L13662").Select
ActiveWindow.SmallScroll Down:=-6
Columns("M:M").Select
End Sub
It looks like your issue is on the 5th row from the end.
Based on this answer you could replace:
Selection.AutoFill Destination:=Range("L2:L13662")
with
Selection.AutoFill Destination:=Range("L2:L" & ActiveSheet.UsedRange.Rows.Count)
Here is an example of vba code that I think will work for your purposes.
'Counts the number of rows in column "C" and then places
'concatenation formula in each adjacent cell (in column "D").
Range("D2:D" & Range("C" & Rows.Count).End(xlUp).Row).Formula = "=CONCATENATE(C2,"", "",B2)"

MID and CONCATENATE in VBA

I'm having the following issue: I recorded a Macro of me using some MID and CONCATENATE formulas after my macro reorders a ton of data. When I run the macro, I get a #REF error, which I understand. However, is there a VBA Code that could remove that or somehow use the MID and CONCATENATE without creating the #REF error? My code is below and any help would be much appreciated.
Sub Macro4()
'
' Macro4 Macro
'
'
Sheets("Sheet2").Select
Cells.Select
Range("D29").Activate
Selection.ClearContents
Selection.End(xlUp).Select
Selection.End(xlToLeft).Select
Sheets("Sheet1").Select
'
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(1, 1), Array(16, 1), Array(21, 1), Array(37, 1), _
Array(42, 1), Array(58, 1), Array(63, 1), Array(79, 1), Array(84, 1), Array(100, 1), Array( _
105, 1), Array(121, 1), Array(129, 1)), TrailingMinusNumbers:=True
Rows("1:6").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Dim lastRow&, g&
Dim findStr$
findStr = "Planning of"
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For g = lastRow To 1 Step -1 ' change this to 2 if you have headers
If Cells(g, 1).Value = findStr Then
'Range(Rows(i), Rows(i - 4)).Select
Range(Rows(g), Rows(g - 4)).EntireRow.Delete
End If
Next g
Dim arr() As Variant
Dim p As Integer, i&
Dim ws As Worksheet
Dim tws As Worksheet
Dim t As Integer
Dim c As Long
Dim u As Long
Set ws = ActiveSheet
Set tws = Worksheets("Sheet2")
i = 1
With ws
Do Until i > 100000
u = 0
For c = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
'If c = .Cells(1, .Columns.Count).End(xlToLeft).Column And .Cells(i, c) <> "" Then
ReDim arr(0) As Variant
p = 0
t = 0
Do Until .Cells(i + p, c) = "" And t = 1
If .Cells(i + p, c) = "" Then
t = 1
Else
arr(UBound(arr)) = .Cells(i + p, c)
ReDim Preserve arr(UBound(arr) + 1)
End If
p = p + 1
Loop
If p > u Then
u = p
End If
If c = .Cells(1, .Columns.Count).End(xlToLeft).Column Then
If .Cells(i + p, c).End(xlDown).Row > 100000 And .Cells(i + p, 1).End(xlDown).Row < 100000 Then
i = .Cells(i + u, 1).End(xlDown).Row
Else
i = .Cells(i + p, c).End(xlDown).Row
End If
End If
tws.Cells(tws.Rows.Count, 1).End(xlUp).Offset(1).Resize(, UBound(arr) + 1) = arr
Next c
Loop
End With
With tws
.Rows(1).Delete
For i = .Cells(1, 1).End(xlDown).Row To 2 Step -1
If Left(.Cells(i, 1), 4) <> Left(.Cells(i - 1, 1), 4) Then
.Rows(i).EntireRow.Insert
End If
Next i
End With
'
' Macro6 Macro
'
'
'Sheets("Sheet2").Select
'Range("A1:M67").Select
'Selection.Copy
'Sheets("Output").Select
'Range("A3").Select
'ActiveSheet.Paste
'Range("A1").Select
ActiveCell.FormulaR1C1 = "=IF(Sheet2!RC="""","""",Sheet2!RC)"
Range("B1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[1],5,4)"
Range("C1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC,1,3)"
Range("D1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC,6,3)"
Range("E1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-1],1,4)"
Range("F1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-2],10,4)"
Range("F2").Select
Columns("F:F").EntireColumn.AutoFit
Range("G1").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-3]="""","""",RC[-3])"
Range("H1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-3],5,3)"
Range("H1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-3],6,3)"
Range("I1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-4],1,4)"
Range("J1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-5],10,4)"
Range("K1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-5],6,3)"
Range("K2").Select
Columns("K:K").EntireColumn.AutoFit
Range("G1").Select
Selection.Copy
Range("K1").Select
ActiveSheet.Paste
Range("L1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-6],6,3)"
Range("M1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-7],1,4)"
Range("N1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-8],10,4)"
Range("O1").Select
ActiveCell.FormulaR1C1 = ""
Range("K1").Select
Selection.Copy
Range("O1").Select
ActiveSheet.Paste
Range("O1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=IF(RC[-3]="""","""",RC[-3])"
Range("P1").Select
Columns("P:P").ColumnWidth = 7.71
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-9],6,3)"
Range("Q1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-10],1,4)"
Range("R1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-11],10,4)"
Range("O1").Select
Selection.Copy
Range("S1").Select
ActiveSheet.Paste
Range("T1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-12],6,3)"
Range("U1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-13],1,4)"
Range("V1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-14],10,3)"
Range("V1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-14],10,4)"
Range("V2").Select
Columns("U:U").EntireColumn.AutoFit
Range("S1").Select
Selection.Copy
Range("W1").Select
ActiveSheet.Paste
Range("X1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-15],6,3)"
Range("Y1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!R[10]C[-16],1,4)"
Range("Y1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-16],1,4)"
Range("Z1").Select
ActiveCell.FormulaR1C1 = ""
Range("W1").Select
Selection.Copy
Range("Z1").Select
ActiveSheet.Paste
Range("Z1").Select
Columns("Z:Z").EntireColumn.AutoFit
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-17],10,4)"
Range("AA1").Select
ActiveCell.FormulaR1C1 = ""
Range("W1").Select
Selection.Copy
Range("AA1").Select
ActiveSheet.Paste
Range("AB1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-18],6,3)"
Range("AC1").Select
ActiveCell.FormulaR1C1 = "=Sheet2!R[113]C[-19]"
Range("AC1").Select
ActiveCell.FormulaR1C1 = "eet2!J114"
Range("AC1").Select
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-19],1,4)"
Range("AA1").Select
Selection.Copy
Range("AD1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=MID(Sheet2!RC[-20],10,4)"
Range("W1").Select
Selection.Copy
Range("AD1").Select
ActiveSheet.Paste
Range("AD1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=IF(OR(RC[-3]="""",AE=""""),"""",RC[-3])"
Range("AD1").Select
ActiveCell.FormulaR1C1 = "=IF(OR(RC[-3]="""",RC[1]=""""),"""",RC[-3])"
Range("A1:AD1").Select
Selection.AutoFill Destination:=Range("A1:AD123"), Type:=xlFillDefault
Range("A1:AD123").Select
ActiveWindow.SmallScroll Down:=-108
Range("V23").Select
ActiveWindow.SmallScroll Down:=-21
Columns("AD:AD").Select
Selection.Copy
Columns("G:G").Select
ActiveSheet.Paste
Columns("K:K").Select
ActiveSheet.Paste
Columns("O:O").Select
ActiveSheet.Paste
Columns("S:S").Select
ActiveSheet.Paste
Columns("W:W").Select
ActiveSheet.Paste
Columns("AA:AA").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-27
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.End(xlToLeft).Select
Sheets("Sheet4").Select
Range("A3").Select
ActiveWindow.SmallScroll Down:=-6
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=IF(Sheet3!R[-2]C="""","""",Sheet3!R[-2]C)"
Range("B3").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Sheet3!R[-2]C,"" "",Sheet3!R[-2]C[1],Sheet3!R[-2]C[2],"" "",Sheet3!R[-2]C[3])"
Range("B3").Select
Selection.Copy
Range("C3").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Sheet3!R[-2]C[3],"" "",Sheet3!R[-2]C[4],Sheet3!R[-2]C[5],"" "",Sheet3!R[-2]C[6])"
Range("D3").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Sheet3!R[-2]C[6],"" "",Sheet3!R[-2]C[7],Sheet3!R[-2]C[8],"" "",Sheet3!R[-2]C[9])"
Range("E3").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Sheet3!R[-2]C[9],"" "",Sheet3!R[-2]C[10],Sheet3!R[-2]C[11],"" "",Sheet3!R[-2]C[12])"
Range("F3").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Sheet3!R[-2]C[12],"" "",Sheet3!R[-2]C[13],Sheet3!R[-2]C[14],"" "",Sheet3!R[-2]C[15])"
Range("G3").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Sheet3!R[-2]C[15],"" "",Sheet3!R[-2]C[16],Sheet3!R[-2]C[17], ,Sheet3!R[-2]C[18])"
Range("G3").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Sheet3!R[-2]C[15],"" "",Sheet3!R[-2]C[16],Sheet3!R[-2]C[17],"" "",Sheet3!R[-2]C[18])"
Range("H3").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Sheet3!R[-2]C[18],"" "",Sheet3!R[-2]C[19],Sheet3!R[-2]C[20],"" "")"
Range("H3").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Sheet3!R[-2]C[18],"" "",Sheet3!R[-2]C[19],Sheet3!R[-2]C[20],"" "",Sheet3!R[-2]C[21])"
Range("H4").Select
Sheets("Sheet3").Select
ActiveWindow.SmallScroll Down:=-12
Sheets("Sheet4").Select
Range("A3:H3").Select
Selection.AutoFill Destination:=Range("A3:H193"), Type:=xlFillDefault
Range("A3:H193").Select
ActiveWindow.SmallScroll Down:=-201
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Output").Select
Range("A1").Select
ActiveWindow.SmallScroll Down:=-12
Sheets("Sheet4").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
ActiveWindow.SmallScroll Down:=-48
Range("A116").Select
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Output").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
I couldn't figure out how to fix the VBA so I simply ran the code without the MID and CONCATENATE in there. Once I did that, I copy and pasted my results into a new tab and entered the equations.

Make the VBA code go faster

How can i make my code go faster?
It's go real slow when the Vlookup is active and i don't know how to make it go fast.
It takes more than 2 minute and it's the same as doing manually.
Sub
Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("J1").Select
ActiveCell.FormulaR1C1 = "KEY"
Range("I1").Select
ActiveCell.FormulaR1C1 = "CHECK"
Range("J2").Select
ActiveCell.FormulaR1C1 = "=RC[7]&RC[12]&RC[16]"
Range("J2").Select
Selection.AutoFill Destination:=Range("j2:j" & cells(Rows.Count, "a").End(xlUp).Row)
Sheets("CSI Plans Report").Select
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Application.Calculation = xlManual
Sheets("CSI Plan ww").Select
Range("J1:N1").Select
Selection.Copy
Sheets("CSI Plans Report").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.AutoFilter
Selection.AutoFilter
Range("A2").Select
ActiveCell.FormulaR1C1 = "=RC[7]&RC[12]&RC[16]"
Range("B2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'CSI Plan ww'!C[8]:C[12],2,0)"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],'CSI Plan ww'!C[7]:C[11],3,0)"
Range("D2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],'CSI Plan ww'!C[6]:C[10],4,0)"
Range("E2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],'CSI Plan ww'!C[5]:C[9],5,0)"
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)
Range("B2").Select
Selection.AutoFill Destination:=Range("b2:b" & cells(Rows.Count, "f").End(xlUp).Row)
Range("C2").Select
Selection.AutoFill Destination:=Range("c2:c" & cells(Rows.Count, "f").End(xlUp).Row)
Range("D2").Select
Selection.AutoFill Destination:=Range("d2:d" & cells(Rows.Count, "f").End(xlUp).Row)
Range("E2").Select
Selection.AutoFill Destination:=Range("e2:e" & cells(Rows.Count, "f").End(xlUp).Row)
Application.Calculation = xlAutomatic
Range("A:E").Select
Range("A:E").Copy
Range("A:E").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("CSI Plan ww").Select
Range("I2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[1],'CSI Plans Report'!C[-8]:C[-3],6,0)"
Range("I2").Select
Selection.AutoFill Destination:=Range("i2:i" & cells(Rows.Count, "a").End(xlUp).Row)
Columns("I:J").Copy
Columns("I:J").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
This:
Range("A:E").Select
Range("A:E").Copy
Range("A:E").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
can be written as just:
Range("A:E").Value = Range("A:E").Value
to achieve best performance in excel VBA try to not use Select.
instead of
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)
better use this
Range("A2").AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)
And best what you can do is to specify sheet too (but it has nothing to do with performance, its just good practice)
Sheets("someSheetName").Range("A2").AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)
And i strongly recomend to use on begining of your sub
application.screenUpdating = false
and this on end of your sub
application.screenUpdating = true
So your excel wont show any change imediately, but at once at the end of the code. (you can read more about screenUpdating almost everywhere on web)
I think this can make you some performance boost.
If you turn off calculation you will save significant periods of time that would otherwise be devoted to calculating formulas that are only oin to be recalculated later.
If you put your formulas into all the rows at once, you do not have to have the calculation on; if you put them into a single cell and fill down you need to run a calculation cycle.
Anytime you can do multiple things at once is better than doing things repeatedly.
Everyone will tell you to read this. It is good advice.
Here's is my contribution to the rewrite process.
Option Explicit
Sub sonic()
Dim lr As Long
'uncomment the next line when you have completed debugging
'appTGGL bTGGL:=False 'see appTGGL helper sub below for details on suspending the enviroment
With Worksheets("CSI Plan ww") '<~~you should know what worksheet you are on!!
'don't insert a sinle column twice - insert 2 columns
.Columns("I:J").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'never do something twice when you do two things at once
.Range("I1:J1") = Array("CHECK", "KEY")
'write all of the formulas at once
.Range(.Cells(2, "J"), .Cells(Rows.Count, "A").End(xlUp).Offset(0, 9)). _
FormulaR1C1 = "=RC17&RC22&RC26"
End With
With Worksheets("CSI Plans Report")
'again - all at once
.Columns("A:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'no need to select to make a copy
Worksheets("CSI Plan ww").Range("J1:N1").Copy _
Destination:=.Range("A1")
'collect the last row so it doesn't have to be repeatedly looked up
lr = .Cells(Rows.Count, "F").End(xlUp).Row
'each column's formulas all at once
.Range("A2:A" & lr).FormulaR1C1 = "=RC8&RC13&RC17"
.Range("B2:B" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 2, 0)"
.Range("C2:C" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 3, 0)"
.Range("D2:D" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 4, 0)"
.Range("E2:E" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 5, 0)"
.Range("A2:E" & lr) = .Range("A2:E" & lr).Value2 'use .Value if any of these are dates
End With
With Worksheets("CSI Plan ww")
.Range(.Cells(2, "I"), .Cells(Rows.Count, "A").End(xlUp).Offset(0, 8)). _
FormulaR1C1 = "=VLOOKUP(RC10,'CSI Plans Report'!C1:C6, 6, 0)"
'collect the last row so it doesn't have to be repeatedly looked up
lr = .Cells(Rows.Count, "J").End(xlUp).Row
'revert formulas to values
.Range("I2:J" & lr) = .Range("I2:J" & lr).Value2 'use .Value if any of these are dates
End With
appTGGL 'turn everything back on
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
With Application
.ScreenUpdating = bTGGL
.EnableEvents = bTGGL
.DisplayAlerts = bTGGL
.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
.CutCopyMode = False
.StatusBar = vbNullString
End With
Debug.Print Timer
End Sub
What I usually do, when writing macros is the following:
Public Sub MyMainMacro
Call OnStart
'Here comes the code
Call OnEnd
End Sub
Public Sub OnStart()
Application.ScreenUpdating = False
Application.Calculation = xlAutomatic
Application.EnableEvents = False
End Sub
Public Sub OnEnd()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.StatusBar = False
End Sub

Filter data in a column and then count

I have recorded a macro to make changes to a sheet. Basically it makes a few changes such as add a column move two columns over and so forth. The thing that I am confused with is adding a small code to give me a count of the total DL and IDL in the MO REAL column L separately and putting the total count on another sheet in the same workbook "Resultados" in cells B17 and C17... Any ideas on how this can be accomplished? Here is the recorded code:
Option Explicit
Sub DefineDL_IDL()
Dim wbTHMacro As Workbook, wsRegulares As Worksheet, wsRegularesDemitidos As Worksheet, wsTempActivos As Worksheet, _
wsTempJA As Worksheet, wsTempFit As Worksheet, wsTempDemitidos As Worksheet, wsPS As Worksheet, wsResultados As Worksheet, _
wsDLList As Worksheet, wssheet As Worksheet
Sheets("Regulares").Select
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
Range("J1").Select
ActiveCell.FormulaR1C1 = "MO REAL"
Columns("K:K").Select
Selection.Cut
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Columns("Q:Q").Select
Selection.Cut
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Range("K1").Select
Selection.AutoFilter
ActiveSheet.Range("A:Z").AutoFilter Field:=11, Criteria1:= _
"INATIVE"
Rows("5:5").Select
Range("F5").Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("A:Z").AutoFilter Field:=11
Range("L2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],'DL List'!RC[-11]:R[32]C[-10],2,0)"
Range("L2").Select
Selection.AutoFill Destination:=Range("L2:L5890")
Range("L2:L5890").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("L2").Select
ActiveSheet.Range("A:Z").AutoFilter Field:=11, Criteria1:="DL"
ActiveSheet.Range("A:Z").AutoFilter Field:=12, Criteria1:="#N/A"
Range("L23").Select
ActiveCell.FormulaR1C1 = "DL"
Range("L23").Select
Selection.Copy
Range("L25").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("A:Z").AutoFilter Field:=12
Range("L4").Select
ActiveSheet.Range("A:Z").AutoFilter Field:=11, Criteria1:=Array( _
"G&A", "MOH", "IDL", "Other MOH"), Operator:=xlFilterValues
ActiveSheet.Range("A:Z").AutoFilter Field:=12, Criteria1:="#N/A"
Range("L7").Select
ActiveCell.FormulaR1C1 = "IDL"
Range("L7").Select
Selection.Copy
Range("L15").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
ActiveSheet.Paste
Application.CutCopyMode = False
Range("L7").Select
ActiveWorkbook.Worksheets("Regulares").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Regulares").AutoFilter.Sort.SortFields.Add Key:= _
Range("K1:K5890"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
:=xlSortNormal
ActiveSheet.Range("A:Z").AutoFilter Field:=12
Range("K2").Select
ActiveSheet.Range("A:Z").AutoFilter Field:=11
Range("G2").Select
ActiveCell.FormulaR1C1 = "1"
Range("G2").Select
Selection.Copy
Range("J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
Range("J2").Select
Application.CutCopyMode = False
End Sub
If you are counting the times "DL" and "IDL" occur...
'Count DL and IDL
count_DL = Application.WorksheetFunction.CountIf(ActiveSheet.Range("L:L"), "DL")
count_IDL = Application.WorksheetFunction.CountIf(ActiveSheet.Range("L:L"), "IDL")
'Paste results in Resultados sheet
Worksheets("Resultados").Range("B17") = count_DL
Worksheets("Resultados").Range("C17") = count_IDL
Your question is a little confusing without understanding a broader picture of what you're doing. All you need to do to get a count and put it in another sheet is:
Sheets("AnotherSheet").Range("B13") = Application.WorksheetFunction.CountA(Columns("G:G"))

Excel Macro generating single random output

I recorded a macro that runs through a bunch of formatting and splicing of data. It basically formats the data page, then splices it into months. The data roughly looks like this:
Column A ... Column D ... Column H Column I Jan Feb ... Nov Dec
- 00645 - budget 45.2 32.8 -15.0 100.00
Basically it fills in entries for all of column A (all entries are "LINE"), renames header on columns B, C, D, H, and I, then copys columns A-J and moves it to a tab created just for the specific month, then deletes column J so the next month will always be in column J and continues repeating till all months are parsed out. Its a pretty easy macro, mostly recorded, but its behaving strangely.
The issue is that once it runs, it randomly inputs the value that is only supposed to be in column A ("LINE") to a single cell somewhere else in the file. It seems semi-random which cell it is. If you put in data from File A, no matter how many times you run the macro "LINE" will show up in the same cell. But it will be a different cell for Files B, C, D and so on. There is nothing fundamentially different about the cell it does this in when compared to the other cells (same entry, same formatting, etc). I have no idea why its doing this. Below is my code:
Sub Format_Upload()
Format_Upload Macro
ActiveCell.FormulaR1C1 = "LINE"
LastRow = Range("B" & Rows.Count).End(xlUp).Row
Range("A2").Copy Range("A2").Resize(LastRow - 1)
Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Dept ID"
Range("C1").Select
ActiveCell.FormulaR1C1 = "MSUPLOAD1"
Range("D1").Select
ActiveCell.FormulaR1C1 = "01/01/14"
Range("I1").Select
ActiveCell.FormulaR1C1 = "01/01/14"
Range("D1").Select
Selection.NumberFormat = "mm/dd/yy;#"
Range("I1").Select
Selection.NumberFormat = "mm/dd/yy;#"
Cells.Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("J:U").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Selection.NumberFormat = "0.00"
Columns("A:J").Select
Selection.Copy
Sheets("JAN").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("Data").Select
Columns("J:J").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("A:J").Select
Selection.Copy
Sheets("FEB").Select
Range("A1").Select
ActiveSheet.Paste
Range("D1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "2/1/2014"
Range("I1").Select
ActiveCell.FormulaR1C1 = "2/1/2014"
Range("H1").Select
Sheets("Data").Select
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("A:J").Select
Selection.Copy
Sheets("MAR").Select
Range("A1").Select
ActiveSheet.Paste
Range("D1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "3/1/2014"
Range("I1").Select
ActiveCell.FormulaR1C1 = "3/1/2014"
Range("I2").Select
Sheets("Data").Select
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("A:J").Select
Selection.Copy
Sheets("APR").Select
ActiveSheet.Paste
Range("D1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "4/1/2014"
Range("I1").Select
ActiveCell.FormulaR1C1 = "4/1/2014"
Range("I2").Select
Sheets("Data").Select
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("A:J").Select
Range("J1").Activate
Selection.Copy
Sheets("MAY").Select
ActiveSheet.Paste
Range("D1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "5/1/2014"
Range("I1").Select
ActiveCell.FormulaR1C1 = "5/1/2014"
Range("I2").Select
Sheets("Data").Select
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("A:J").Select
Selection.Copy
Sheets("JUN").Select
ActiveSheet.Paste
Range("D1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "6/1/2014"
Range("I1").Select
ActiveCell.FormulaR1C1 = "6/1/2014"
Range("I2").Select
Sheets("Data").Select
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("A:J").Select
Selection.Copy
Sheets("JUL").Select
ActiveSheet.Paste
Range("D1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "7/1/2014"
Range("I1").Select
ActiveCell.FormulaR1C1 = "7/1/2014"
Range("I2").Select
Sheets("Data").Select
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("A:J").Select
Selection.Copy
Sheets("AUG").Select
ActiveSheet.Paste
Range("D1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "8/1/2014"
Range("I1").Select
ActiveCell.FormulaR1C1 = "8/1/2014"
Range("I2").Select
Sheets("Data").Select
Columns("J:J").Select
Selection.Copy
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("A:J").Select
Selection.Copy
Sheets("SEP").Select
ActiveSheet.Paste
Range("D1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "9/1/2014"
Range("I1").Select
ActiveCell.FormulaR1C1 = "9/1/2014"
Range("I2").Select
Sheets("Data").Select
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Selection.Copy
Sheets("OCT").Select
Sheets("Data").Select
Columns("A:J").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("OCT").Select
Range("A1").Select
ActiveSheet.Paste
Range("D1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "10/1/2014"
Range("I1").Select
ActiveCell.FormulaR1C1 = "10/1/2014"
Range("I2").Select
Sheets("Data").Select
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("A:J").Select
Selection.Copy
Sheets("NOV").Select
ActiveSheet.Paste
Range("D1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "11/1/2014"
Range("I1").Select
ActiveCell.FormulaR1C1 = "11/1/2014"
Range("I2").Select
Sheets("Data").Select
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("A:J").Select
Selection.Copy
Sheets("DEC").Select
ActiveSheet.Paste
Columns("D:D").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "12/1/2014"
Range("I1").Select
ActiveCell.FormulaR1C1 = "12/1/2014"
Range("I2").Select
Sheets("Data").Select
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Sheets("FEB").Select
ActiveCell.FormulaR1C1 = "MSFEB"
Sheets("MAR").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "MSMAR"
Sheets("APR").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "MSAPR"
Sheets("MAY").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "MSMAY"
Sheets("JUN").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "MSJUN"
Sheets("JUL").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "MSJUL"
Sheets("AUG").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "MSAUG"
Sheets("SEP").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "MSSEP"
Sheets("OCT").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "MSOCT"
Sheets("NOV").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "MSNOV"
Sheets("DEC").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "MSDEC"
Range("H2").Select
End Sub
I do not see anything in the code that explains this anomaly. Any ideas as to what's causing this issue?
'
EDIT: The strange cell always appears on the first tab (named "JAN"), but its location varies.
ActiveCell.FormulaR1C1 = "LINE"
This is putting "LINE" in whichever cell you have selected before running it.
Change that to something else