VBA code hanging Excel - vba

I wrote a code to grab the raw data in a file and summarize the data based to "date" of report and copy this summarized data into the target workbook according to the "date" value.
When I tried to run this code. it works fine for one file, but hangs up in another file. When I try to debug it I am not able to follow the flow of code. It breaks up suddenly. Can you help me in fixing this issue?
Option Explicit
Sub file_select()
Dim RequiredFileName As Variant, i As Integer
Dim targetWorkbook As Workbook
' making weak assumption that active workbook is the target
Set targetWorkbook = Application.ActiveWorkbook
'RequiredFileName = "c:\myfiles\test.xls"
On Error GoTo EndNow
RequiredFileName = Application.GetOpenFilename(FileFilter:="ALL Files (*.*), *.*", Title:="Get File", MultiSelect:=True)
For i = 1 To UBound(RequiredFileName)
MsgBox RequiredFileName(i), , GetFileName(CStr(RequiredFileName(i)))
Next i
For i = 1 To UBound(RequiredFileName)
Call ProcessOpenFile(RequiredFileName(i), targetWorkbook)
Next i
EndNow: End Sub
Function GetFileName(filespec As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(filespec)
End Function
Sub ProcessOpenFile(RequiredFileName, targetWorkbook As Workbook)
Dim RequiredWorkbook As Workbook
'Dim targetWorkbook As Workbook
' get the required workbook
Set RequiredWorkbook = Application.Workbooks.Open(RequiredFileName)
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets("Summary_NV")
Dim RequiredSheet As Worksheet
Set RequiredSheet = RequiredWorkbook.Sheets(1) 'here assumed that source workbook consists only of one sheet i.e., is the required sheet.
RequiredWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
RequiredWorkbook.Sheets(Sheets.Count).Select
RequiredWorkbook.Sheets(Sheets.Count).Name = "SUMMARY" & Sheets.Count
Call Sort_Before(RequiredWorkbook) 'sorting the required file data according to date.
If RequiredSheet.Name = "EVDO_SC_Summary" Then
Call ProcessEVDO(RequiredSheet) 'get the summary of report
Call Sort_After(RequiredWorkbook) ' sort the summary according to date
Call DateChange(RequiredWorkbook) 'changing date format
ElseIf RequiredSheet.Name = "CDMAVoice_SC_Summary" Then
Call ProcessVoice(RequiredSheet)
Call Sort_After(RequiredWorkbook)
Call DateChange(RequiredWorkbook)
ElseIf RequiredSheet.Name = "CDMAData_SC_Summary" Then
Call ProcessData(RequiredSheet)
Call Sort_After(RequiredWorkbook)
Call DateChange(RequiredWorkbook)
End If
Dim iRow As Integer
Dim LastRow_Req As Integer
Dim LastRow_Tar As Integer
Dim LastCol_Req As Integer
LastRow_Req = RequiredWorkbook.Sheets(Sheets.Count).Cells(Rows.Count, 1).End(xlUp).Row 'last row summary data
LastCol_Req = RequiredWorkbook.Sheets(Sheets.Count).Cells(1, Columns.Count).End(xlToLeft).Column 'last column of summary data
LastRow_Tar = targetSheet.Cells(Rows.Count, 1).End(xlUp).Row 'last row of target sheet used
RequiredWorkbook.Sheets(Sheets.Count).Range("B1").Resize(LastRow_Req, LastCol_Req - 1).Select 'selecting summary data for copying
Selection.Copy
If targetSheet.Cells(LastRow_Tar, 1).Value < RequiredWorkbook.Sheets(Sheets.Count).Range("A1").Value Then 'if date entered in target sheet last cell is less
If RequiredWorkbook.Sheets(1).Name = "EVDO_SC_Summary" Then 'then the summary report date
targetSheet.Activate
Cells(LastRow_Tar + 1, 16).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(LastRow_Tar + 1, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, LastRow_Tar + 1, 1)
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAVoice_SC_Summary" Then
targetSheet.Activate
Cells(LastRow_Tar + 1, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(LastRow_Tar + 1, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, LastRow_Tar + 1, 1)
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAData_SC_Summary" Then
targetSheet.Activate
Cells(LastRow_Tar + 1, 9).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(LastRow_Tar + 1, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, LastRow_Tar + 1, 1)
End If
End If
For iRow = targetSheet.Range("A12").Row To LastRow_Tar
RequiredWorkbook.Activate
If targetSheet.Cells(iRow, 1).Value < RequiredWorkbook.Sheets(Sheets.Count).Range("A1").Value Then
GoTo A
ElseIf targetSheet.Cells(iRow, 1).Value = RequiredWorkbook.Sheets(Sheets.Count).Range("A1").Value Then
If RequiredWorkbook.Sheets(1).Name = "EVDO_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 16).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
Exit For
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAVoice_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
Exit For
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAData_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 9).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
Exit For
End If
ElseIf targetSheet.Cells(iRow, 1).Value > RequiredWorkbook.Sheets(Sheets.Count).Range("A1").Value Then
If RequiredWorkbook.Sheets(1).Name = "EVDO_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 16).Select
Selection.Insert Shift:=xlDown
Exit For
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAVoice_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 2).Select
Selection.Insert Shift:=xlDown
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
Exit For
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAData_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 9).Select
Selection.Insert Shift:=xlDown
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
Exit For
End If
End If
A: Next
RequiredWorkbook.Close savechanges:=False
End Sub

Answered in a comment "Code is going into infinite loop" – user1806794

Related

Keeping Conditional Formatting

Hi I'm busy with a VBA macro that copies data from one sheet to another, problem is whenever i paste the data to the other sheet, the conditional formatting falls off.It messes up with what i want to achieve. Isn't there a code I could use to keep conditional formatting. here is my code:
'In this example I am Copying the Data from Sheet1 (Source) to Sheet2
(Destination)
Sub sbCopyRangeToAnotherSheet()
'Method 1
Application.ScreenUpdating = False
'Set active sheet as current sheet
temp = ActiveSheet.Index
'Clear contents in sheet 1
Sheets("Sheet1").Select
Range("B22").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
'Clear Specials in Sheet 1
Range("B13").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
'Return to current sheet and copy required contents
Sheets(temp).Select
Range("D51").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Paste data in sheet 1
Worksheets("Sheet1").Activate
k = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Range("B22").Select ' kindly change the code to suit your paste location
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Copy specials over to sheet1
Sheets(temp).Select
Range("i36").Select
p = Range(Selection, Selection.End(xlDown)).Count
j = 0
For k = 1 To p
Sheets(temp).Select
t = Range("i36").Offset(k - 1, 0).Value
s = Range("j36").Offset(k - 1, 0).Value
If t = True Then
Sheets("Sheet1").Select
j = j + 1
Range("b13").Offset(j - 1, 0).Value = s
Else: End If
Next k
'Delete Empty Rows In UPL
Dim iRow As Long, lastRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1") 'qualify your sheet
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row 'find last used row
For iRow = lastRow To 1 Step -1 'run from last used row backwards to row 1
If ws.Cells(iRow, 3).Text = "#N/A" Or _
ws.Cells(iRow, 4).Text = "#N/A" Then
ws.Rows(iRow).Delete
End If
Next iRow
' Paste Unit Into UPL
Sheets(temp).Select
temp = Sheets(temp).Range("d35").Value
model = Range("D26").Value
Sheets("Sheet1").Select
Range("B11").Value = temp & " " & model
End Sub
Please Assist
so I recommend to replace this:
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
with this:
Selection.PasteSpecial Paste:=xlPasteAllMergingConditionalFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False 'so that Excel will not be in the copy mode

Stack Three Macros into One VBA Command

I have three macros (below) that work separately, but when I sandwich them together, only the first macro executes properly. I'm not getting an error; the other two macros just don't seem to run. Any advice on how to link them together so I can execute all at once?
Macro 1
Sub Update_Workbook()
Dim QryStr As String, cell As String
Dim a As Integer, b As Integer
Dim cellv As Variant
'Pause spreadsheet calculations until end of sub
Application.Calculation = xlManual
ActiveWorkbook.Sheets("Raw Data").Select
'Clear cells to import query
With Range("A1:O1").EntireColumn
.ClearContents
.NumberFormat = "General"
.Validation.Delete
End With
'Process SQL query string
QryStr = ActiveSheet.TextBox1.Value
Do While InStr(QryStr, "{&")
a = InStr(QryStr, "{&")
b = InStr(a, QryStr, "}")
cell = Mid(QryStr, a + 2, b - a - 2)
cellv = Range(cell).Value
If IsDate(cellv) Then
cellv = Format(cellv, "dd-mmm-yy")
End If
QryStr = Replace(QryStr, "{&" & cell & "}", cellv)
Loop
'Import data from query
With ActiveSheet.QueryTables.Add(Connection:="ODBC;DRIVER={Oracle in OraClient11g_home1};UID=xx;PWD=xx;SERVER=xx;DBQ=xx", _
Destination:=Range("A1"), Sql:=QryStr)
.MaintainConnection = False
.BackgroundQuery = False
.RefreshStyle = xlOverwriteCells
.Refresh
.Delete
End With
Finish_Sub:
Call ClearUnneededNames
Application.Calculation = xlCalculationAutomatic
End Sub
Sub ClearUnneededNames()
Dim savedNames As Integer
savedNames = 0
Do While ActiveSheet.Names.Count > savedNames
If InStr(ActiveSheet.Names(savedNames + 1).Name, "ExternalData") = 0 Then
savedNames = savedNames + 1
Else
ActiveSheet.Names(savedNames + 1).Delete
End If
Loop
End Sub
Macro 2
Sub Five_Felicia_for_MFG()
'
' Macro3 Macro
'
'
Range("A3:M3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=-18
Range(Selection, Selection.End(xlUp)).Select
Range("A3:M1010").Select
Selection.Delete Shift:=xlUp
Sheets("5Felicia").Select
Range("A3:M34").Select
Selection.Copy
Sheets("5Felicia for MFG").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("5Felicia").Select
Range("A37:M37").Select
Range(Selection, Selection.End(xlDown)).Select
Range("A37:M692").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("5Felicia for MFG").Select
ActiveWindow.SmallScroll Down:=18
Range("A36").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=-48
Columns("A:M").Select
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$M$691").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
7, 8, 9, 10, 11, 12, 13), Header:=xlNo
End Sub
Macro 3
Sub DUMMY_ITEMS()
'
' DUMMY_ITEMS Macro
Dim LastRow As Long
Sheets("Operations").Range("H2:V73").Copy
With Sheets("Raw Data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & LastRow + 1).PasteSpecial xlPasteValues
End With
End Sub
In VBA a Module can have several macros (or, more accurately, subroutines) in it.
But, when you call one of those macros, execution stops at the End Sub statement. Nothing else in the module will run regardless of how you "sandwich" them together within the module.
But subroutines can call other subroutines. So code like this will run all three of your macros:
Sub RunAllThree()
Update_Workbook
Five_Felicia_for_MFG
DUMMY_ITEMS
End Sub

Trying to copy specific columns in a row to another excel sheet based on it meeting certain criteria

Im very new to excel/vba and trying to use a macro to check a column for the value true, when it sees that value I'd like it to copy parts of that row to another sheet in my column. Then I need it to iterate through the other rows and perform the same checks. Here is my code currently.
Sub Macro3()
'
' Macro3 Macro
'
'
Sheets("Aspen Data").Select
Dim tfCol As Range, Cell As Object
Set tfCol = Range("G26:G56")
Sheets("Code").Select
ActiveSheet.Calculate
Sheets("Aspen Data").Select
ActiveSheet.Calculate
For Each Cell In tfCol
If IsEmpty(Cell) Then
Exit Sub
End If
If Cell.Value = "True" Then
Range("I26:Q26").Select
Selection.Copy
Sheets("AspenHist").Select
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
End Sub
The issue appears to be in getting my Range("I26:Q26) to increment by one as it goes through the loop.
Try this
Sheets("Aspen Data").Select
Dim i As Integer
Sheets("Code").Calculate
Sheets("Aspen Data").Calculate
For i = 26 To 56
If IsEmpty(Cells(i, 7)) Then
Exit Sub
ElseIf Cells(i, 7).Value = "True" Then
Range(Cells(i, 9), Cells(i, 12)).Copy
Sheets("AspenHist").Activate
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Aspen Data").Activate
End If
Next i
There's no need to use .Select/.Activate/ActiveSheet (see this) to accomplish your goals, and you can definitely use For Each. Try this:
Option Explicit
Sub Macro1()
'
' Macro1 Macro
'
'
Dim tfCol As Range, Cell As Object
Set tfCol = Sheets("Aspen Data").Range("G26:G56")
Application.ScreenUpdating = False
Sheets("Code").Calculate
Sheets("Aspen Data").Calculate
For Each Cell In tfCol
If IsEmpty(Cell) Then
Exit For
End If
If Cell.Value = "True" Then
Sheets("Aspen Data").Range("I" & Cell.Row & ":Q" & Cell.Row).Copy
Sheets("AspenHist").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Next
Application.ScreenUpdating = True
End Sub

Loop to copy results of filtered table

I'm working on a work schedule, where I have a list of employees name and a flat table with everyone schedule per day. My macro should for each employee filter the data, copy it and paste it in a new sheet with his/her name.
Sub EnvoiPlanning()
'Sheets("People").Range("B:B").RemoveDuplicates Columns:=1, Header:= _
xlYes
Dim i As Integer
i = 2
While Sheets("People").Cells(i, 1) <> ""
Sheets("Data").Range("A:O").AutoFilter Field:=2, Criteria1:=Sheets("People").Cells(i, 1).Value
Sheets("Data").Range("A:F").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets(Sheets.Count).Name = Sheets("People").Cells(2, 1).Value
i = i + 1
Wend
End Sub
There is error:
Run-time error '1004': Select method of Range class failed
on the second instruction of the loop after the first iteration.
Try this :
Sub EnvoiPlanning()
'Sheets("People").Range("B:B").RemoveDuplicates Columns:=1, Header:= _
xlYes
Dim i As Integer, _
Ws As Worksheet
i = 2
While Sheets("People").Cells(i, 1) <> ""
Sheets("Data").Range("A:O").AutoFilter Field:=2, Criteria1:=Sheets("People").Cells(i, 1).Value
Sheets("Data").Range("A:F").Copy
Set Ws = Sheets.Add(After:=Sheets(Sheets.Count))
Ws.Range("A1").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Ws.Name = Sheets("People").Cells(2, 1).Value
i = i + 1
Wend
End Sub

Many workbooks consolidation

hello i'm having a problem with the macro bellow on the line 21,
worksheets.add.name = shtname
it seams to me that it's not changing the value of the shtname string once it end the first loop
i´d like to know what's happening hre is the code:
Sub lsConsolidarPlanilhas()
Dim lWorkbook As Workbooks
Dim lWorksheet As Worksheet
Dim lUltimaLinhaAtiva As Long
Dim lControle As Long
Dim lUltimaLinhaAtiva2 As Long
Dim lUltimaLinhaAtiva3 As Long
Dim lUltimaLinhaAtiva4 As Long
Dim shtname As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
lUltimaLinhaAtiva = Worksheets("Configuração").Cells(Worksheets("Configuração").Rows.Count, 1).End(xlUp).Row
lControle = 2
While lControle <= lUltimaLinhaAtiva
If (Workbooks("Macros.xlsm").Worksheets("Configuração").Range("B" & lControle).Value <> "") Then
shtname = Range("B" & lControle).Text
Worksheets.Add.name = shtname
End If
If (Workbooks("Macros.xlsm").Worksheets("Configuração").Range("B" & lControle).Value <> "") Then
Workbooks.Open Filename:=Worksheets("Configuração").Range("A" & lControle).Value
Set lworkbooks = ActiveWorkbook
If (ActiveWorkbook.Sheets.Count > 1) Then
Workbooks(lworkbooks.name).Worksheets("<LVC>").Activate
lUltimaLinhaAtiva2 = Worksheets("<LVC>").Cells(Worksheets("<LVC>").Rows.Count, 1).End(xlUp).Row
Worksheets("<LVC>").Select
Worksheets("<LVC>").Range("A1:AI18").Select
Selection.Copy
lUltimaLinhaAtiva3 = Workbooks("Macros.xlsm").Worksheets(shtname).Cells(Workbooks("Macros.xlsm").Worksheets(shtname).Rows.Count, 1).End(xlUp).Row + 1
Workbooks("Macros.xlsm").Worksheets(shtname).Activate
Workbooks("Macros.xlsm").Worksheets(shtname).Range("A" & lUltimaLinhaAtiva3).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
For i = 1 To ActiveWorkbook.Sheets.Count
Workbooks(lworkbooks.name).Worksheets(i).Activate
lUltimaLinhaAtiva2 = Worksheets(i).Cells(Worksheets(i).Rows.Count, 1).End(xlUp).Row
Worksheets(i).Select
Worksheets(i).Range("A19:AI" & lUltimaLinhaAtiva2).Select
Selection.Copy
lUltimaLinhaAtiva4 = Workbooks("Macros.xlsm").Worksheets(shtname).Cells(Workbooks("Macros.xlsm").Worksheets(shtname).Rows.Count, 1).End(xlUp).Row + 1
Workbooks("Macros.xlsm").Worksheets(shtname).Activate
Workbooks("Macros.xlsm").Worksheets(shtname).Range("A" & lUltimaLinhaAtiva4).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
End If
Workbooks(lworkbooks.name).Worksheets("<LVC>").Activate
lUltimaLinhaAtiva2 = Worksheets("<LVC>").Cells(Worksheets("<LVC>").Rows.Count, 1).End(xlUp).Row
Worksheets("<LVC>").Select
Worksheets("<LVC>").Range("A1:AI" & lUltimaLinhaAtiva2).Select
Selection.Copy
lUltimaLinhaAtiva3 = Workbooks("Macros.xlsm").Worksheets(shtname).Cells(Workbooks("Macros.xlsm").Worksheets(shtname).Rows.Count, 1).End(xlUp).Row + 1
Workbooks("Macros.xlsm").Worksheets(shtname).Activate
Workbooks("Macros.xlsm").Worksheets(shtname).Range("A" & lUltimaLinhaAtiva3).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else:
Workbooks.Open Filename:=Worksheets("Configuração").Range("A" & lControle).Value
Set lworkbooks = ActiveWorkbook
If (ActiveWorkbook.Sheets.Count > 1) Then
For i = 1 To ActiveWorkbook.Sheets.Count
Workbooks(lworkbooks.name).Worksheets(i).Activate
lUltimaLinhaAtiva2 = Worksheets(i).Cells(Worksheets(i).Rows.Count, 1).End(xlUp).Row
Worksheets(i).Select
Worksheets(i).Range("A19:AI" & lUltimaLinhaAtiva2).Select
Selection.Copy
lUltimaLinhaAtiva4 = Workbooks("Macros.xlsm").Worksheets(shtname).Cells(Workbooks("Macros.xlsm").Worksheets(shtname).Rows.Count, 1).End(xlUp).Row + 1
Workbooks("Macros.xlsm").Worksheets(shtname).Activate
Workbooks("Macros.xlsm").Worksheets(shtname).Range("A" & lUltimaLinhaAtiva4).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
End If
Workbooks(lworkbooks.name).Worksheets("<LVC>").Activate
lUltimaLinhaAtiva2 = Worksheets("<LVC>").Cells(Worksheets("<LVC>").Rows.Count, 1).End(xlUp).Row
Worksheets("<LVC>").Select
Worksheets("<LVC>").Range("A19:AI" & lUltimaLinhaAtiva2).Select
Selection.Copy
lUltimaLinhaAtiva3 = Workbooks("Macros.xlsm").Worksheets(shtname).Cells(Workbooks("Macros.xlsm").Worksheets(shtname).Rows.Count, 1).End(xlUp).Row + 1
Workbooks("Macros.xlsm").Worksheets(shtname).Activate
Workbooks("Macros.xlsm").Worksheets(shtname).Range("A" & lUltimaLinhaAtiva3).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Workbooks(lworkbooks.name).Close
lControle = lControle + 1
Wend
Worksheets("Configuração").Select
Worksheets("Configuração").Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Planilhas consolidadas!"
End Sub
Thank you #Cor_Blimey that really was the problem, once i've especified the workbook for the shtname it worked perfectly
"unqualified Range() function implicitly refers to the active worksheet which is probably not what was intended. Make it fully qualified by adding Workbooks("Macros.xlsm").Worksheets("Configuração"). in front of it. In general, also, I suggest refactoring the code to eliminate all .Select and .Activate and and instead assigning to temporary worksheet variables so it is transparent and clear what is being acted on (e.g. Set sourceWb = ...Set sourceWs = sourceWb.Worksheets(1)...etc – Cor_Blimey 22 hours ago"