Runtime error in VBA Excel - vba

I am comparing two column D and E in my sheet which are containing Dates.
The column E has date and sometime there are no Dates and sometime it has X, in the row. I get an runtime error
type mismatch
Could anyone suggest what is wrong with my code. ?
Sub datecompare()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim zWeeks As Double, zcolour As Long
Dim Ztext As String
Set ws = Sheets("Preparation Sheet")
With ws
lRow = .range("D" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
zWeeks = DateDiff("ww", .range("E" & i).Value, .range("D" & i).Value)
If .range("A" & i).Value <> "" And .range("B" & i).Value <> "" And .range("E" & i).Value = "" Then
Ztext = "remaining"
zcolour = vbYellow
Cells(i, 7) = "Yellow"
ElseIf .range("B" & i).Value = "" And .range("E" & i).Value = "" Then
GoTo nextrow
ElseIf zWeeks < 4 Then
Ztext = " on time"
zcolour = vbGreen
Cells(i, 7) = "Green"
ElseIf zWeeks > 8 Then
Ztext = " delayed"
zcolour = vbRed
Cells(i, 7) = "Red"
ElseIf zWeeks > 4 < 8 Then
Ztext = "remaining"
zcolour = vbYellow
Cells(i, 7) = "Yellow"
End If
With .range("F" & i)
.Value = Ztext
.Interior.Color = zcolour
End With
nextrow:
Next i
End With
End Sub
The error occurs at
GoTo nextrow
and it jumps to next, without running through the in between code.

I think, the code woult to be like this.
Sub datecompare()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim zWeeks As Double, zcolour As Long
Dim Ztext As String
Set ws = Sheets("Preparation Sheet")
'Cells.Interior.Color = xlNone
With ws
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If IsDate(.Range("E" & i).Value) And IsDate(.Range("D" & i).Value) Then
Else
GoTo nextrow
End If
zWeeks = DateDiff("ww", .Range("E" & i).Value, .Range("D" & i).Value)
If .Range("A" & i).Value <> "" And .Range("B" & i).Value <> "" And .Range("E" & i).Value = "" Then
Ztext = "remaining"
zcolour = vbYellow
Cells(i, 7) = "Yellow"
Else '<~~ .Range("A" & i).Value <> "" And .Range("B" & i).Value <> "" And .Range("E" & i).Value = "" true or false , this is false
If .Range("B" & i).Value = "" And .Range("E" & i).Value = "" Then
GoTo nextrow
Else '<~~ .Range("B" & i).Value = "" And .Range("E" & i).Value = "" Then true or false, this is false
'<~~ When the result is false, after code applied
If zWeeks < 4 Then
Ztext = " on time"
zcolour = vbGreen
Cells(i, 7) = "Green"
ElseIf zWeeks > 8 Then
Ztext = " delayed"
zcolour = vbRed
Cells(i, 7) = "Red"
ElseIf zWeeks >= 4 And zWeeks <= 8 Then
Ztext = "remaining"
zcolour = vbYellow
Cells(i, 7) = "Yellow"
End If
End If
End If
With .Range("F" & i)
.Value = Ztext
.Interior.Color = zcolour
End With
nextrow:
Next i
End With
End Sub

Related

MACRO works in stepping through but breaks when run via button

I had created a Macro that reads data from a sheet and create journal entries. I had to update the macro due to some changes to the spreadsheet however now my macro doesnt work.
My macro works if I step through the entire thing or if I hit the play button in the VSB screen. However If I hit the macro button I embedded in spreadsheet, it breaks. I believe its breaking because its skipping this section:
If Cells(iRow2, 1) = "CCC $" Then
wsUp.Cells(iRow2, 1).Value = "CC"
ElseIf Cells(iRow2, 1) = "DDD $" Then
I am not sure why it is skipping this only when I bit the embedded button and not when I run it from the VSB screen.
Sub CreateAllocations_JEs()
Dim iRow As Integer, iCol As Integer, iRow2 As Integer
Dim sEntity As String, sEnt2 As String, sVal1 As String, sEnt3 As String, sDesc2 As String
Dim wsEntry As Worksheet
Dim wsUp As Worksheet
Dim wsInst As Worksheet
Set wsInst = Worksheets("Instructions")
Set wsEntry = Worksheets("Entries")
Set wsUp = Worksheets("Sheet1")
Dim lastrow As Long
Dim sRange As Range
Dim sQLNE As Long
''' Creates expense for holdings
For iRow = 6 To 35
lastrow = wsUp.Cells(Rows.Count, "A").End(xlUp).Row
sEntity = wsEntry.Range("D5").Value
sAcct = wsEntry.Range("N" & iRow).Value
sAcct2 = wsEntry.Range("M" & iRow).Value
sDesc = wsEntry.Range("O" & iRow).Value
vsum = Application.WorksheetFunction.Sum(wsEntry.Range("E" & iRow & ":J" & iRow))
If vsum > 0 Then
wsUp.Range("A" & lastrow + 1).Value = sEntity
wsUp.Range("J" & lastrow + 1).Value = vsum
wsUp.Range("G" & lastrow + 1).Value = sAcct
''''' Adds description column using the companies that have payables
sDesc2 = ""
End If
For iCol = 5 To 12
If wsEntry.Cells(iRow, iCol) > 0 Then
sEnt3 = wsEntry.Cells(5, iCol).Value
If sDesc2 <> "" Then
sDesc2 = sDesc2 & ", "
End If
sDesc2 = sDesc2 & sEnt3
End If
Next iCol
wsUp.Range("M" & lastrow + 1).Value = sDesc & sDesc2
'''''' Creates receivable for holdings and related fields
For iCol = 5 To 10
If wsEntry.Cells(iRow, iCol) > "0" Then
sVal1 = wsEntry.Cells(iRow, iCol).Value
sDesc = wsEntry.Range("O" & iRow).Value
sEnt3 = wsEntry.Cells(5, iCol).Value
lastrow = wsUp.Cells(Rows.Count, "A").End(xlUp).Row
wsUp.Range("A" & lastrow + 1).Value = sEntity
wsUp.Range("I" & lastrow + 1).Value = sVal1
vRec = Application.WorksheetFunction.Index(Sheets("IC accounts").Range("C:C"), Application.WorksheetFunction.Match(Sheets("Entries").Cells(5, iCol), Sheets("IC accounts").Range("B:B"), 0), 1)
wsUp.Range("G" & lastrow + 1).Value = vRec
wsUp.Range("M" & lastrow + 1).Value = sDesc & sEnt3
End If
Next iCol
''''Creates the payables and expense in other companies
For iCol = 5 To 12
If wsEntry.Cells(iRow, iCol) > "0" Then
sEnt2 = wsEntry.Cells(5, iCol).Value
sval2 = wsEntry.Cells(iRow, iCol).Value
lastrow = wsUp.Cells(Rows.Count, "A").End(xlUp).Row
wsUp.Range("A" & lastrow + 1, "A" & lastrow + 2).Value = sEnt2
If wsUp.Range("A" & lastrow + 1).Value = "AAA $" Then
wsUp.Range("J" & lastrow + 1).Value = sval2
wsUp.Range("I" & lastrow + 2).Value = sval2
wsUp.Range("G" & lastrow + 1).Value = sAcct2
wsUp.Range("G" & lastrow + 2).Value = "00-1320001"
ElseIf wsUp.Range("A" & lastrow + 1).Value = "BBB $" Then
wsUp.Range("J" & lastrow + 1).Value = sval2
wsUp.Range("I" & lastrow + 2).Value = sval2
wsUp.Range("G" & lastrow + 1).Value = sAcct2
wsUp.Range("G" & lastrow + 2).Value = "00-1320002"
Else
wsUp.Range("I" & lastrow + 1).Value = sval2
wsUp.Range("J" & lastrow + 2).Value = sval2
wsUp.Range("G" & lastrow + 1).Value = sAcct2
wsUp.Range("G" & lastrow + 2).Value = "00-4100040"
End If
wsUp.Range("M" & lastrow + 1, "M" & lastrow + 2).Value = sDesc & sEntity
End If
Next iCol
Next iRow
lastrow = wsUp.Cells(Rows.Count, "A").End(xlUp).Row
For iRow2 = 2 To lastrow
If Cells(iRow2, 1) = "CCC $" Then
wsUp.Cells(iRow2, 1).Value = "CC"
ElseIf Cells(iRow2, 1) = "DDD $" Then
wsUp.Cells(iRow2, 1).Value = "DD"
ElseIf Cells(iRow2, 1) = "EEE $" Then
wsUp.Cells(iRow2, 1).Value = "EE"
ElseIf Cells(iRow2, 1) = "FFF $" Then
wsUp.Cells(iRow2, 1).Value = "FF"
ElseIf Cells(iRow2, 1) = "GGG $" Then
wsUp.Cells(iRow2, 1).Value = "GG"
ElseIf Cells(iRow2, 1) = "HHH $" Then
wsUp.Cells(iRow2, 1).Value = "LLL"
ElseIf Cells(iRow2, 1) = "AAA $" Then
wsUp.Cells(iRow2, 1).Value = "LLL"
ElseIf Cells(iRow2, 1) = "LLL $" Then
wsUp.Cells(iRow2, 1).Value = "LLL"
ElseIf Cells(iRow2, 1) = "JJJ $" Then
wsUp.Cells(iRow2, 1).Value = "JJ"
End If
wsUp.Activate
Code Breaks Here. I beleive because skips section above.
vCN =
Application.WorksheetFunction.Index(Sheets("Company").Range("B:B"),
Application.WorksheetFunction.Match(Sheets("Sheet1").Cells(iRow2, 1),
Sheets("Company").Range("A:A"), 0), 1)
wsUp.Range("B" & iRow2).Value = vCN
vAN = Application.WorksheetFunction.Index(Sheets("COA").Range("B:B"),
Application.WorksheetFunction.Match(Sheets("Sheet1").Cells(iRow2, 7),
Sheets("COA").Range("A:A"), 0), 1)
wsUp.Range("H" & iRow2).Value = vAN
sQLNE = wsUp.Cells(Rows.Count, "N").End(xlUp).Row
wsUp.Range("N" & iRow2).Value = sQLNE
wsUp.Range("S" & iRow2).Value = wsUp.Range("I" & iRow2).Value
wsUp.Range("T" & iRow2).Value = wsUp.Range("J" & iRow2).Value
Next iRow2
lastrow = wsUp.Cells(Rows.Count, "A").End(xlUp).Row
sBatch = wsInst.Cells(8, 2).Value
sMonth = wsInst.Cells(6, 2).Value
sYear = wsInst.Cells(7, 2).Value
sDate = wsInst.Cells(5, 2).Value
sRef = sBatch & sMonth & sYear
wsUp.Range("C2", "C" & lastrow).Value = sRef
wsUp.Range("f2", "F" & lastrow).Value = sRef
wsUp.Range("D2", "D" & lastrow).Value = "1"
wsUp.Range("e2", "E" & lastrow).Value = "0"
wsUp.Range("K2", "k" & lastrow).Value = sDate
wsUp.Range("I:J").NumberFormat = "0.00"
wsUp.Range("S:T").NumberFormat = "0.00"
For iRow2 = 2 To lastrow
If Cells(iRow2, 9) = "" Then
wsUp.Cells(iRow2, 9).Value = "0.00"
wsUp.Cells(iRow2, 19).Value = "0.00"
ElseIf Cells(iRow2, 10) = "" Then
wsUp.Cells(iRow2, 10).Value = "0.00"
wsUp.Cells(iRow2, 20).Value = "0.00"
End If
Next iRow2
wsInst.Activate
End Sub
The code skips your if block because the parent for the cell has not been mentioned so it uses the activesheet, you have to explicitly mention that so instead of
If Cells(iRow2, 1) = "CCC $" Then
by this line:
MySheet.Cells(iRow2, 1) = "CCC $" Then
I don't know which one of the sheets is MySheet in your code, so replace it yourself

VBA for matching Sheet 1 columns to Sheet 2 columns

Sheet 1 has columns A-T. Some columns of Sheet 1 have formulas and others have a dropdown list.
Sheet 2 has columns A-P. I want to be able to paste the Sheet 1 data in Sheet 2-- The data generated as a result of formulas and drop downs. Also in a way, that if I change anything in Sheet 1 it changes on the other sheet. I want to be able to do this for multiple columns.
The thing is that Sheet 1 and Sheet 2 columns are not true to each other. I mean Column A of Sheet 1 is Column C in Sheet 2 etc..
Right now, I have simply equaled the cells using formula on both sheets to make this work. I don't wish to continue it this way. Macro will be better.
Thank you! Please help.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2")
hC = "AO"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:T"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range("C" & Lr).Value = Range("C" & R).Value
.Range("D" & Lr).Value = Range("D" & R).Value
.Range("E" & Lr).Value = Range("E" & R).Value
.Range("F" & Lr).Value = Range("F" & R).Value
.Range("G" & Lr).Value = Range("G" & R).Value
.Range("H" & Lr).Value = Range("H" & R).Value
.Range("I" & Lr).Value = Range("I" & R).Value
.Range("J" & Lr).Value = Range("J" & R).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("L" & Lr).Value = Range("K" & R).Value
.Range("M" & Lr).Value = Range("L" & R).Value
.Range("N" & Lr).Value = Range("M" & R).Value
.Range("O" & Lr).Value = Range("N" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
Edited Code (3_31_3017)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Route_Sheet")
hC = "AP"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:AL"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range(.Cells(Lr, "C"), .Cells(Lr, "J")).Value = Range(Cells(R, "C"), Cells(R, "J")).Value
.Range(.Cells(Lr, "L"), .Cells(Lr, "O")).Value = Range(Cells(R, "K"), Cells(R, "N")).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range("Q" & Lr).Value = Range("U" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
We need at least one thing to know that row(x) in Sheet 1 is related to row(y) in Sheet 2. this can be done by adding unique identifier for each row as #tigeravatar mentioned or by adding one formula in unused column in row(x) in Sheet 1 relating to row(y) in Sheet 2.
In Sheet 1 Module add this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2")
hC = "U" 'Change this to any unused column and You can hide it
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:T"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
' Add here all columns you need like :
'=====================================
.Range("C" & Lr).Value = Range("A" & R).Value
.Range("A" & Lr).Value = Range("B" & R).Value
'...etc
'=====================================
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
Edit:
Right click on "Master" sheet tab and select View Code and paste this code in it:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2") 'Change "Sheet 2" to your target sheet name like "Route_Sheet" or "Lists"
hC = "AO"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:AH"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row
If Not (Lr = 1 And .Range(hC & Lr).Value = vbNullString) Then Lr = Lr + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range(.Cells(Lr, "C"), .Cells(Lr, "J")).Value = Range(Cells(R, "C"), Cells(R, "J")).Value
.Range(.Cells(Lr, "L"), .Cells(Lr, "O")).Value = Range(Cells(R, "K"), Cells(R, "N")).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
This is a Worksheet Event that run automatically when user change any cell inside Columns("A:AH").
If you want to run it manually you can add new sub in Module1:
Sub Test()
With sheets("Master").Range("A2:A50") ' change this range to all rows you need like "A5:A100"
.Value = .Value
End With
End Sub
Or:
Sub Test()
With Sheets("Master")
Application.Run .CodeName & ".Worksheet_Change", .Range("A1:A50") 'change this range to all rows you need like "A5:A100"
End With
End Sub

Match cell value to a combobox row value

I'm trying to figure out a different method of running a piece of code.
Basically what my code is doing at the moment is, looping though column Q in the Global sheet, then looping though Combobox2, when it finds a match the entire rows get moved to the sheet reference in column 1 of the combobox.
Is it possible to use the Match function to achieve the same results and speed up the code??
This is currently the code I'm using, it does what I need it to do, but I cannot get error handling working for it. And it there are many rows of data to loop through it can take a long time!
Option 1:
Private Sub CommandButton6_Click()
Dim i As Long, j As Long, lastG As Long, strWS As String, rngCPY As Range
Dim StartTime As Double
Dim SecondsElapsed As Double
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
End With
StartTime = Timer
If Range("L9") = "" Then
MsgBox "You can't Split the Jobs at this stage. " & vbLf & vbLf & "Please create the form for the Sub-Contractor First." & vbLf & vbLf & "Please press Display Utilities to create form.", vbExclamation, "Invalid Operation"
Exit Sub
End If
If sheets("Global").Range("A3") = "" Then
MsgBox "The appears to be no application loaded." & vbLf & vbLf & "Please load" & " " & Range("C11") & " " & "App and Planet Info, then click button 2 and try again.", vbExclamation, "Invalid Operation"
Exit Sub
End If
On Error GoTo bm_Close_Out
' find last row
lastG = sheets("Global").Cells(Rows.Count, "Q").End(xlUp).row
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
If sheets("PAYMENT FORM").Range("L40") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
For i = 3 To lastG
lookupVal = sheets("Global").Cells(i, "Q") ' value to find
If lookupVal = currval Then
Set rngCPY = sheets("Global").Cells(i, "Q").EntireRow
strWS = Me.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet '<~~ if the worksheet in the next line does not exist, go make one
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
End If
Next i
Next j
End If
Else
If sheets("PAYMENT FORM").Range("L35") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
For i = 3 To lastG
lookupVal = sheets("Global").Cells(i, "Q") ' value to find
If lookupVal = currval Then
Set rngCPY = sheets("Global").Cells(i, "Q").EntireRow
strWS = Me.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet '<~~ if the worksheet in the next line does not exist, go make one
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
End If
Next i
Next j
End If
End If
GoTo bm_Close_Out
bm_Need_Worksheet:
On Error GoTo 0
With Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTemplate As Worksheet: Set wsTemplate = wb.sheets("Template")
Dim wsPayment As Worksheet: Set wsPayment = wb.sheets("Payment Form")
Dim wsNew As Worksheet
Dim lastRow2 As Long
Dim Contract As String: Contract = sheets("Payment Form").Range("C9").value
Dim SpacePos As Integer: SpacePos = InStr(Contract, "- ")
Dim Name As String: Name = Left(Contract, SpacePos)
Dim Name2 As String: Name2 = Right(Contract, Len(Contract) - Len(Name))
Dim NewName As String: NewName = strWS
Dim CCName As Variant: CCName = Me.ComboBox2.List(j, 2)
Dim LastRow As Long: LastRow = wsPayment.Range("U36:U53").End(xlDown).row
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
lastRow2 = wsPayment.Range("A23:A39").End(xlDown).row
Else
lastRow2 = wsPayment.Range("A18:A34").End(xlDown).row
End If
wsTemplate.Visible = True
wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
wsTemplate.Visible = False
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsPayment
For Each cell In .Range("A23:A39")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
Else
With wsPayment
For Each cell In .Range("A18:A34")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
End If
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A23:A39").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
Else
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A18:A34").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
End If
wsPayment.Activate
With wsPayment
.Range("J" & lastRow2 + 1).value = 0
.Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
.Range("N" & lastRow2 + 1).Formula = "='" & NewName & "'!L20"
.Range("U" & LastRow + 1).value = NewName & ": "
.Range("V" & LastRow + 1).Formula = "='" & NewName & "'!I21"
.Range("W" & LastRow + 1).Formula = "='" & NewName & "'!I23"
.Range("X" & LastRow + 1).Formula = "='" & NewName & "'!K21"
End With
End With
On Error GoTo bm_Close_Out
Resume
bm_Close_Out:
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
End With
End Sub
Option 2:
Private Sub CommandButton1_Click()
Dim j As Long, strWS As String, rngCPY As Range, FirstAddress As String, sSheetsWithData As String
Dim sSheetsWithoutData As String, lSheetRowsCopied As Long, lAllRowsCopied As Long, bFound As Boolean, sOutput As String
Dim StartTime As Double
Dim SecondsElapsed As Double
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
.EnableEvents = False
End With
StartTime = Timer
On Error GoTo bm_Close_Out
For j = 0 To UserForm2.ComboBox2.ListCount - 1
bFound = False
currval = UserForm2.ComboBox2.List(j, 0) ' value to match
With sheets("Global")
Set rngCPY = sheets("Global").Range("Q:Q").Find(currval, LookIn:=xlValues)
If Not rngCPY Is Nothing Then
bFound = True
lSheetRowsCopied = 0
FirstAddress = rngCPY.Address
Do
lSheetRowsCopied = lSheetRowsCopied + 1
strWS = UserForm2.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet
With Worksheets(strWS)
rngCPY.EntireRow.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
Set rngCPY = sheets("Global").Range("Q:Q").FindNext(rngCPY)
Loop Until rngCPY Is Nothing Or rngCPY.Address = FirstAddress
Else
bFound = False
End If
If bFound Then
sSheetsWithData = sSheetsWithData & " " & strWS & " (" & lSheetRowsCopied & ")" & vbLf
lAllRowsCopied = lAllRowsCopied + lSheetRowsCopied
End If
End With
Next j
bm_Need_Worksheet:
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTemplate As Worksheet: Set wsTemplate = wb.sheets("Template")
Dim wsPayment As Worksheet: Set wsPayment = wb.sheets("Payment Form")
Dim wsNew As Worksheet
Dim lastRow2 As Long
Dim Contract As String: Contract = sheets("Payment Form").Range("C9").value
Dim SpacePos As Integer: SpacePos = InStr(Contract, "- ")
Dim Name As String: Name = Left(Contract, SpacePos)
Dim Name2 As String: Name2 = Right(Contract, Len(Contract) - Len(Name))
Dim NewName As String: NewName = strWS
Dim CCName As Variant: CCName = UserForm2.ComboBox2.List(j, 2)
Dim LastRow As Long: LastRow = wsPayment.Range("U36:U53").End(xlDown).row
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
lastRow2 = wsPayment.Range("A23:A39").End(xlDown).row
Else
lastRow2 = wsPayment.Range("A18:A34").End(xlDown).row
End If
wsTemplate.Visible = True
wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
wsTemplate.Visible = False
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsPayment
For Each cell In .Range("A23:A39")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
Else
With wsPayment
For Each cell In .Range("A18:A34")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
End If
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A23:A39").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
Else
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A18:A34").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
End If
wsPayment.Activate
With wsPayment
.Range("J" & lastRow2 + 1).value = 0
.Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
.Range("N" & lastRow2 + 1).Formula = "='" & NewName & "'!L20"
.Range("U" & LastRow + 1).value = NewName & ": "
.Range("V" & LastRow + 1).Formula = "='" & NewName & "'!I21"
.Range("W" & LastRow + 1).Formula = "='" & NewName & "'!I23"
.Range("X" & LastRow + 1).Formula = "='" & NewName & "'!K21"
End With
On Error GoTo bm_Close_Out
Resume
bm_Close_Out:
If sSheetsWithData <> vbNullString Then
sOutput = "# of rows copied to sheets:" & vbLf & vbLf & sSheetsWithData & vbLf & _
"Total rows copied = " & lAllRowsCopied & vbLf & vbLf
Else
sOutput = "No sheets contained data to be copied" & vbLf & vbLf
End If
If sSheetsWithoutData <> vbNullString Then
sOutput = sOutput & "Sheets with no rows copied:" & vbLf & vbLf & sSheetsWithoutData
Else
sOutput = sOutput & "All sheets had data that was copied."
End If
If sOutput <> vbNullString Then MsgBox sOutput, , "Copy Report"
Set rngCPY = Nothing
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
.EnableEvents = True
End With
End Sub
OK... It's more like a try than an answer. pls check if that is working and if it is faster.
Use this macro only with a copy of your workbook!
Private Sub CommandButton2_Click()
Dim i As Long, j As Long, k As Long, strWS As String, rngCPY As Range
Dim noFind As Variant: noFind = UserForm2.ComboBox2.List '<~~~ get missed items
With Application: .ScreenUpdating = False: .EnableEvents = False: .CutCopyMode = False: End With
If Range("L9") = "" Then: MsgBox "You can't Split the Jobs at this stage. " & vbLf & vbLf & "Please create the form for the Sub-Contractor First." & vbLf & vbLf & "Please press Display Utilities to create form.", vbExclamation, "Invalid Operation": Exit Sub
Dim lastG As Long: lastG = Sheets("Global").Cells(Rows.Count, 17).End(xlUp).row
Dim cVat As Boolean: cVat = InStr(1, Sheets("Payment Form").Range("A20").Value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE")
If Sheets("PAYMENT FORM").Cells(35 - cVat * 5, 12) >= 1 Then: MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation": Exit Sub
'~~~ acivate next line to sort (will speed up a lot)
'Sheets("Global").Range("A3:R" & Cells(Rows.Count, 17).End(xlUp).row).Sort cells(3,17), 1
For j = 0 To UserForm2.ComboBox2.ListCount - 1
noFind(j, 4) = 0
For i = 3 To lastG
If noFind(j, 0) = Sheets("Global").Cells(i, 17) Then
k = i
strWS = UserForm2.ComboBox2.List(j, 1)
On Error Resume Next
If Len(Worksheets(strWS).Name) = 0 Then
With ThisWorkbook
On Error GoTo 0
Dim nStr As String: With Sheets("Payment Form").Range("C9"): nStr = Right(.Value, Len(.Value) - Len(Left(.Value, InStr(.Value, "- ")))): End With
Dim CCName As Variant: CCName = UserForm2.ComboBox2.List(j, 2)
Dim lastRow As Long: lastRow = Sheets("Payment Form").Range("U36:U53").End(xlDown).row + 1
Dim strRng As String: strRng = Array("A18:A34", "A23:A39")(-1 * cVat)
Dim lastRow2 As Long: lastRow2 = Sheets("Payment Form").Range(strRng).End(xlDown).row + 1
Dim wsNew As Worksheet: .Sheets("Template").Copy .Sheets(.Sheets.Count): Set wsNew = .Sheets(.Sheets.Count): wsNew.Move .Sheets("Details")
With Sheets("Payment Form")
For Each cell In .Range(strRng)
If Len(cell) = 0 Then
If Sheets("Payment Form").Range("C9").Value = "Network" Then
cell.Offset.Value = strWS & " - " & nStr & ": " & CCName
Else
cell.Offset.Value = strWS & " -" & nStr & ": " & CCName
End If
Exit For
End If
Next cell
End With
With wsNew
.Visible = -1
.Name = strWS
.Cells(4, 4).Value = Sheets("Payment Form").Range(strRng).End(xlDown).Value
.Cells(6, 4).Value = Sheets("Payment Form").Cells(12, 12).Value
.Cells(8, 4).Value = Sheets("Payment Form").Cells(9, 3).Value
.Cells(10, 4).Value = Sheets("Payment Form").Cells(11, 3).Value
End With
With .Sheets("Payment Form")
.Activate
.Cells(lastRow2, 10).Value = 0
.Cells(lastRow2, 12).Formula = "=N" & lastRow2 & "-J" & lastRow2 & ""
.Cells(lastRow2, 14).Formula = "='" & strWS & "'!L20"
.Cells(lastRow, 21).Value = strWS & ": "
.Cells(lastRow, 22).Formula = "='" & strWS & "'!I21"
.Cells(lastRow, 23).Formula = "='" & strWS & "'!I23"
.Cells(lastRow, 24).Formula = "='" & strWS & "'!K21"
End With
End With
End If
On Error GoTo 0
While Sheets("Global").Cells(k + 1, 17).Value = noFind(j, 0) And k < lastG
k = k + 1
Wend
Set rngCPY = Sheets("Global").Range("Q" & i & ":Q" & k).EntireRow
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
noFind(j, 4) = noFind(j, 4) + k - i + 1
i = k
End If
Next i
Next j
With Application: .ScreenUpdating = True: .EnableEvents = True: .CutCopyMode = True: End With
'noFind(x, y) > x = item / y: 0 = name / y: 4 = counter
noFind(0, 0) = noFind(0, 0) & " " & noFind(0, 4) & " times copied"
For i = 1 To UBound(noFind)
noFind(0, 0) = noFind(0, 0) & vbLf & noFind(i, 0) & " " & noFind(i, 4) & " times copied"
Next
MsgBox noFind(0, 0)
End Sub
At first: you may add some empty lines for better understanding...
Most parts are just shortened by view (they still do tha same).
When using the sort option, it will copy/paste all rows for each keyword in one step. That not only sounds faster... However, you may resort at the end again
Pls check if it works with your real workbook (copy of it, but with all data inside). I haven't done any "indeep speed tuning".
Here is a small section of your code that replace the loop through each cell in Global!Q3:Q*<last_row>* with the VBA version of the MATCH function.
Dim rw As Long, rngGQs As Range '<~~ put this closer to the top with the other variable declarations
' find last row
'lastG = Sheets("Global").Cells(Rows.Count, "Q").End(xlUp).Row '<~~old way
With Sheets("Global") '<~~new way
Set rngGQs = .Range(Cells(3, "Q"), .Cells(Rows.Count, "Q").End(xlUp)) '< ~~ all of the cells to look at
End With
If InStr(1, Sheets("Payment Form").Range("A20").Value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
If Sheets("PAYMENT FORM").Range("L40") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
'For i = 3 To lastG '<~~old way
'lookupVal = Sheets("Global").Cells(i, "Q") ' value to find
'If lookupVal = currval Then
If Not IsError(Application.Match(currval, rngGQs, 0)) Then '<~~new way
rw = Application.Match(currval, rngGQs, 0)
Set rngCPY = Sheets("Global").Cells(rw, "Q").EntireRow
'all the rest here
When you get this to a satisfactory working order, it will be a prime candidate for suggestions at Code Review (Excel).
You could try something like this. The Range.Find-Method basically looks through the given range for a value which you can specify. If a match is found, the cell in which the match is found, can then be stored.
You can then also use .FindNext to find the next occurrence of that value, if needed.
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
Set rngCPY = sheets("Global").Range("Q:Q").Find(currval, LookIn:=xlValues)
Do While Not rngCPY Is Nothing
strWs = Me.ComboBox2.List(j, 1)
rngCPY.EntireRow.Copy
With Worksheets(strWS)
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
Set rngCPY = sheets("Global").Range("Q:Q").FindNext(rngCPY)
Loop
Next j

Delete empty rows using VBA - MS Excel

I am looking to see if there is a more efficient way to achieve the result below, so it can be extended if needed.
I'm using this to clean up large spreadsheets that have the rows C-Z blank. I imagine there should be a way to clean it up so that it doesn't have to double in size if I need to clean up a spreadsheet with data from C to AZ.
It's been a while since I used VBA, I found the code below online. (counting ROW B as the spreadsheet in question had an empty ROW A)
Sub delem()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For r = lr To 1 Step -1
If Range("C" & r).Value = "" And Range("D" & r).Value = "" And Range("E" & r).Value = "" And Range("F" & r).Value = "" And Range("G" & r).Value = "" And Range("H" & r).Value = "" And Range("I" & r).Value = "" And Range("J" & r).Value = "" And Range("K" & r).Value = "" And Range("L" & r).Value = "" And Range("M" & r).Value = "" And Range("N" & r).Value = "" And Range("O" & r).Value = "" And Range("P" & r).Value = "" And Range("Q" & r).Value = "" And Range("R" & r).Value = "" And Range("S" & r).Value = "" And Range("T" & r).Value = "" And Range("U" & r).Value = "" And Range("V" & r).Value = "" And Range("W" & r).Value = "" And Range("X" & r).Value = "" And Range("Y" & r).Value = "" And Range("Z" & r).Value = "" Then Rows(r).Delete
Next r
End Sub
Thanks!
Just add an inner loop to go through the columns you care about. This will actually run much faster, as VBA doesn't short-circuit the If statement (all of the conditionals are evaluated). But with the loop, you can exit early if you find a value anywhere:
Sub delem()
Dim last As Long
Dim current As Long
Dim col As Long
Dim retain As Boolean
last = Cells(Rows.Count, "B").End(xlUp).Row
For current = last To 1 Step -1
retain = False
For col = 3 To 26
If Cells(current, col).Value <> vbNullString Then
retain = True
Exit For
End If
Next col
If Not retain Then Rows(current).Delete
Next current
End Sub
The Excel worksheet function COUNTA is a clean way to test if a range is empty.
Sub delem()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For r = lr To 1 Step -1
'This function Counts the number of cells that are not empty
If WorksheetFunction.CountA(Range(Cells(r, 3), Cells(r, 26)) = 0 Then
Rows(r).Delete
End If
Next r
End Sub

How to use Excel VBA to activate and copy row data from multiple worksheets in multiple workbooks into another workbook's worksheet?

I have a series of workbooks, containing a series of worksheets, in which I am needing to consolidate those worksheets into one worksheet (they are all identical columns).
I have the below snippet from my combined() sub that I'm trying to use to access each file, iterate over them, get each worksheet inside, and then copy the contents of each worksheet over to the combined.xlsm file.
My problem is, I'm not quite following how I should activate the workbooks/worksheets with my code. Is my code just not going to work?
CombinedWB = "Combined.xlsm"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FLS = FSO.GetFolder("c:\path\to\files").Files
Row = 1
For Each F In FLS
CurrentWB = F.Name
Windows(CurrentWB).Activate
If CurrentWB <> CombinedWB Then
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Combined").Delete
Application.DisplayAlerts = True
If Row = 1 Then
Windows(CombinedWB).Activate
For Each Cell In ActiveSheet.Range("A3")
Worksheets("Combined").Range("A" & Row).Value = "Name"
Worksheets("Combined").Range("B" & Row).Value = "Player"
Worksheets("Combined").Range("C" & Row).Value = Cell.Value
Worksheets("Combined").Range("D" & Row).Value = Cell.Offset(0, 1).Value
Worksheets("Combined").Range("E" & Row).Value = Cell.Offset(0, 2).Value
Worksheets("Combined").Range("F" & Row).Value = Cell.Offset(0, 3).Value
Worksheets("Combined").Range("G" & Row).Value = Cell.Offset(0, 4).Value
Worksheets("Combined").Range("H" & Row).Value = Cell.Offset(0, 5).Value
Worksheets("Combined").Range("I" & Row).Value = Cell.Offset(0, 6).Value
Worksheets("Combined").Range("J" & Row).Value = Cell.Offset(0, 7).Value
Worksheets("Combined").Range("K" & Row).Value = Cell.Offset(0, 8).Value
Worksheets("Combined").Range("L" & Row).Value = Cell.Offset(0, 9).Value
Worksheets("Combined").Range("M" & Row).Value = Cell.Offset(0, 10).Value
Worksheets("Combined").Range("N" & Row).Value = Cell.Offset(0, 11).Value
Worksheets("Combined").Range("O" & Row).Value = Cell.Offset(0, 12).Value
Worksheets("Combined").Range("P" & Row).Value = Cell.Offset(0, 13).Value
Next
Windows(CurrentWB).Activate
Row = 2
End If
For J = 1 To Sheets.Count
Player = Sheets(J).Cells(1).Parent.Name
Injury = Sheets(J).Range("A5").Value
InjuryDate = Sheets(J).Range("B5").Value
For Each Cell In Sheets(J).Range("A5:A100")
Windows(CombinedWB).Activate
If IsEmpty(Cell.Offset(0, 2).Value) <> True Then
Worksheets("Combined").Range("A" & Row).Value = Name
Worksheets("Combined").Range("B" & Row).Value = Player
Worksheets("Combined").Range("C" & Row).Value = Injury
Worksheets("Combined").Range("D" & Row).Value = InjuryDate
Worksheets("Combined").Range("E" & Row).Value = Cell.Offset(0, 2).Value
Worksheets("Combined").Range("F" & Row).Value = Cell.Offset(0, 3).Value
Worksheets("Combined").Range("G" & Row).Value = Cell.Offset(0, 4).Value
Worksheets("Combined").Range("H" & Row).Value = Cell.Offset(0, 5).Value
Worksheets("Combined").Range("I" & Row).Value = Cell.Offset(0, 6).Value
Worksheets("Combined").Range("J" & Row).Value = Cell.Offset(0, 7).Value
Worksheets("Combined").Range("K" & Row).Value = Cell.Offset(0, 8).Value
Worksheets("Combined").Range("L" & Row).Value = Cell.Offset(0, 9).Value
Worksheets("Combined").Range("M" & Row).Value = Cell.Offset(0, 10).Value
Worksheets("Combined").Range("N" & Row).Value = Cell.Offset(0, 11).Value
Worksheets("Combined").Range("O" & Row).Value = Cell.Offset(0, 12).Value
Worksheets("Combined").Range("P" & Row).Value = Cell.Offset(0, 13).Value
Row = Row + 1
End If
Next
Next
End If
Next
EDIT
Here is the final working code (thanks to mwolfe02):
Sub Combine()
Dim J As Integer
Dim Sport As String
Dim Player As String
Dim Injury As String
Dim InjuryDate As String
Dim Row As Integer
Dim FSO As Object
Dim FLS As Object
Dim CurrentWB As String
Dim CombinedWB As String
Dim CombinedWBTemp As String
Dim wb As Workbook
Dim cwb As Workbook
Dim ws As Worksheet
Dim cws As Worksheet
CombinedWB = "Combined.xlsm"
CombinedWBTemp = "~$" & CombinedWB
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FLS = FSO.GetFolder("c:\path\to\files").Files
Set cwb = Workbooks(CombinedWB)
Set cws = cwb.Worksheets("Combined")
cws.Range("A1:Z3200").Clear
Row = 1
For Each F In FLS
CurrentWB = F.Name
If CurrentWB <> CombinedWB And CurrentWB <> CombinedWBTemp Then
On Error Resume Next
Set wb = Workbooks.Open(CurrentWB)
On Error Resume Next
If Not wb.Sheets("Combined") Is Nothing Then
Application.DisplayAlerts = False
wb.Sheets("Combined").Delete
Application.DisplayAlerts = True
End If
If Row = 1 Then
For Each Cell In wb.Sheets(1).Range("A3")
cws.Range("A" & Row).Value = "Sport"
cws.Range("B" & Row).Value = "Player"
cws.Range("C" & Row).Value = Cell.Value
cws.Range("D" & Row).Value = Cell.Offset(0, 1).Value
cws.Range("E" & Row).Value = Cell.Offset(0, 2).Value
cws.Range("F" & Row).Value = Cell.Offset(0, 3).Value
cws.Range("G" & Row).Value = Cell.Offset(0, 4).Value
cws.Range("H" & Row).Value = Cell.Offset(0, 5).Value
cws.Range("I" & Row).Value = Cell.Offset(0, 6).Value
cws.Range("J" & Row).Value = Cell.Offset(0, 7).Value
cws.Range("K" & Row).Value = Cell.Offset(0, 8).Value
cws.Range("L" & Row).Value = Cell.Offset(0, 9).Value
cws.Range("M" & Row).Value = Cell.Offset(0, 10).Value
cws.Range("N" & Row).Value = Cell.Offset(0, 11).Value
cws.Range("O" & Row).Value = Cell.Offset(0, 12).Value
cws.Range("P" & Row).Value = Cell.Offset(0, 13).Value
Next
Row = 2
End If
For Each ws In wb.Worksheets
Player = ws.Cells(1).Parent.Name
Injury = ws.Range("A5").Value
InjuryDate = ws.Range("B5").Value
For Each Cell In ws.Range("A5:A100")
If IsEmpty(Cell.Offset(0, 2).Value) <> True Then
cws.Range("A" & Row).Value = wb.Name
cws.Range("B" & Row).Value = Player
cws.Range("C" & Row).Value = Injury
cws.Range("D" & Row).Value = InjuryDate
cws.Range("E" & Row).Value = Cell.Offset(0, 2).Value
cws.Range("F" & Row).Value = Cell.Offset(0, 3).Value
cws.Range("G" & Row).Value = Cell.Offset(0, 4).Value
cws.Range("H" & Row).Value = Cell.Offset(0, 5).Value
cws.Range("I" & Row).Value = Cell.Offset(0, 6).Value
cws.Range("J" & Row).Value = Cell.Offset(0, 7).Value
cws.Range("K" & Row).Value = Cell.Offset(0, 8).Value
cws.Range("L" & Row).Value = Cell.Offset(0, 9).Value
cws.Range("M" & Row).Value = Cell.Offset(0, 10).Value
cws.Range("N" & Row).Value = Cell.Offset(0, 11).Value
cws.Range("O" & Row).Value = Cell.Offset(0, 12).Value
cws.Range("P" & Row).Value = Cell.Offset(0, 13).Value
Row = Row + 1
End If
Next
Next
wb.Close SaveChanges:=True
End If
Next
Windows(CombinedWB).Activate
Sheets("Combined").Activate
End Sub
Your problems are caused by using the .Activate method. There is no need for that in what you are trying to do. Code created using the macro recorder is littered with .Activate calls, but they are generally a bad idea when writing code yourself.
Try something more like this:
Const CombinedWB As String = "Combined.xlsm"
Dim FSO As Object, FLS As Object, F As Object
Dim wb As Workbook, ws As Worksheet
Dim cwb As Workbook 'This will be our combined workbook'
Dim cws As Worksheet 'This will be the combined worksheet'
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FLS = FSO.GetFolder("c:\path\to\files").Files
Set cwb = Workbooks.Open(CombinedWB)
'Use the following line if there is just a single combined worksheet'
' and it is in the combined workbook'
Set cws = cwb.Worksheets("Combined")
For Each F In FLS
Set wb = Workbooks.Open(F.Name)
If F.Name <> CombinedWB Then
....
'Use the following line if each workbook has a combined worksheet'
Set cws = wb.Worksheets("Combined")
For Each ws In wb.Worksheets
cws.Range("A1") = cws.Range("A1") + ws.Range("A1")
....
Next ws
End If
wb.Close SaveChanges:=True
Next F