Jackel
10-03-2016, 07:04 AM
Hello all,
I am having an issue with my macro that I cannot figure out. I spent a few hours Friday trying to break it up, but it into different sections, but nothing worked :banghead:. It is rather long, but in short, it loops through a folder copying and pasting the same columns of data, into one master file.
The problem is, that it gets the first copy and paste section right which is A:E, then it moves over to S:U, but it will not copy the last ones. Instead it copies over column E into column U. Any input or corrections that you can see that need to be made? *One of the last sections is ' out because I was trying to work section by section to solve the problem.
I am monitoring this post very closely so I will be in constant communication as others reply. Thanks!
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls?"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'ENTER USER CODE HERE
Worksheets("Pricing Entry").Activate
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
'Worksheets("Lane Pricing Entry").ShowAllData
'On Error Resume Next
Dim myColm As Range
Set myColm = Range("R:R")
On Error Resume Next
myColm.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Dim wb As Workbook
'Set wb = Workbooks("Eagle Foods TL Bid Tool v1.xlsm")
'
'Lane ID
Dim LRpg1 As Integer
LRpg1 = Range("A" & Rows.Count).End(xlUp).Row
Range("A3:D" & LRpg1).Select
Selection.Copy
'Ignores blank rows, could be handy for when import doesnt delete blank rows
Windows("Master.xlsm").Activate
Sheets("Data Entry").Select
lMaxRows = Cells(Rows.Count, "C").End(xlUp).Row
Range("C" & lMaxRows + 1).Select
ActiveSheet.Paste
Range("C3").Select
Application.CutCopyMode = False
'Origin city, State, zip
Dim LRpg3 As Integer
LRpg3 = Range("I" & Rows.Count).End(xlUp).Row
Range("I3:J").Select
Selection.Copy
Windows("Master.xlsm").Activate
Sheets("Data Entry").Select
lMaxRows = Cells(Rows.Count, "S").End(xlUp).Row
Range("S" & lMaxRows + 1).Select
ActiveSheet.Paste
'Destination City,State,Zip
LRpg4 = Range("G" & Rows.Count).End(xlUp).Row
Range("G3:I" & LRpg1).Select
Selection.Copy
Windows("Master.xlsm").Activate
Sheets("Data Entry").Select
lMaxRows = Cells(Rows.Count, "G").End(xlUp).Row
Range("G" & lMaxRows + 1).Select
ActiveSheet.Paste
'Volume and Milage
wb.Worksheets(1).Activate
Dim LRpg5 As Integer
LRpg5 = Range("I" & Rows.Count).End(xlUp).Row
Range("I3:J" & LRpg5).Select
Selection.Copy
Windows("Master").Activate
Sheets("Data Entry").Select
lMaxRows = Cells(Rows.Count, "Q").End(xlUp).Row
Range("Q" & lMaxRows + 1).Select
ActiveSheet.Paste
'RPM and MIN
'Dim LRpg6 As Integer
'LRpg6 = Range("S" & Rows.Count).End(xlUp).Row
'Range("S3:T" & LRpg6).Select
'Selection.Copy
'wb.Worksheets.Activate
'Windows("Master.xlsm").Activate
'Sheets("Data Entry").Select
'lMaxRows = Cells(Rows.Count, "U").End(xlUp).Row
'Range("U" & lMaxRows + 1).Select
ActiveSheet.Paste
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I am having an issue with my macro that I cannot figure out. I spent a few hours Friday trying to break it up, but it into different sections, but nothing worked :banghead:. It is rather long, but in short, it loops through a folder copying and pasting the same columns of data, into one master file.
The problem is, that it gets the first copy and paste section right which is A:E, then it moves over to S:U, but it will not copy the last ones. Instead it copies over column E into column U. Any input or corrections that you can see that need to be made? *One of the last sections is ' out because I was trying to work section by section to solve the problem.
I am monitoring this post very closely so I will be in constant communication as others reply. Thanks!
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls?"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'ENTER USER CODE HERE
Worksheets("Pricing Entry").Activate
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
'Worksheets("Lane Pricing Entry").ShowAllData
'On Error Resume Next
Dim myColm As Range
Set myColm = Range("R:R")
On Error Resume Next
myColm.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Dim wb As Workbook
'Set wb = Workbooks("Eagle Foods TL Bid Tool v1.xlsm")
'
'Lane ID
Dim LRpg1 As Integer
LRpg1 = Range("A" & Rows.Count).End(xlUp).Row
Range("A3:D" & LRpg1).Select
Selection.Copy
'Ignores blank rows, could be handy for when import doesnt delete blank rows
Windows("Master.xlsm").Activate
Sheets("Data Entry").Select
lMaxRows = Cells(Rows.Count, "C").End(xlUp).Row
Range("C" & lMaxRows + 1).Select
ActiveSheet.Paste
Range("C3").Select
Application.CutCopyMode = False
'Origin city, State, zip
Dim LRpg3 As Integer
LRpg3 = Range("I" & Rows.Count).End(xlUp).Row
Range("I3:J").Select
Selection.Copy
Windows("Master.xlsm").Activate
Sheets("Data Entry").Select
lMaxRows = Cells(Rows.Count, "S").End(xlUp).Row
Range("S" & lMaxRows + 1).Select
ActiveSheet.Paste
'Destination City,State,Zip
LRpg4 = Range("G" & Rows.Count).End(xlUp).Row
Range("G3:I" & LRpg1).Select
Selection.Copy
Windows("Master.xlsm").Activate
Sheets("Data Entry").Select
lMaxRows = Cells(Rows.Count, "G").End(xlUp).Row
Range("G" & lMaxRows + 1).Select
ActiveSheet.Paste
'Volume and Milage
wb.Worksheets(1).Activate
Dim LRpg5 As Integer
LRpg5 = Range("I" & Rows.Count).End(xlUp).Row
Range("I3:J" & LRpg5).Select
Selection.Copy
Windows("Master").Activate
Sheets("Data Entry").Select
lMaxRows = Cells(Rows.Count, "Q").End(xlUp).Row
Range("Q" & lMaxRows + 1).Select
ActiveSheet.Paste
'RPM and MIN
'Dim LRpg6 As Integer
'LRpg6 = Range("S" & Rows.Count).End(xlUp).Row
'Range("S3:T" & LRpg6).Select
'Selection.Copy
'wb.Worksheets.Activate
'Windows("Master.xlsm").Activate
'Sheets("Data Entry").Select
'lMaxRows = Cells(Rows.Count, "U").End(xlUp).Row
'Range("U" & lMaxRows + 1).Select
ActiveSheet.Paste
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub