I am currently working on a code, i have also included for myself since i have to repeat build this for other reports with minro changes each time. some reports the source data will be randomly named and and some will have a set name. I have included verions in both on this to make it easir for me to access.
I am wondering if what i have built has already been simplified / steamlined enough or if there is anything i could do to make it better. I have provided 3 different macros i have built for the same massive report i am working on.
I have included any resources i used & also you will see i turned off/on formulas since teh are some source files that are huge and filled with formulas. i input those lines to save time.
I have also the data being pasted as values since there is a lot of formatting i need to keep teh same.
Any suggestions and feedback would be greatly appreaciated!
Sub Tester_Format_combine()
Dim wb As Workbook
Dim nData As Workbook
Dim Template As Workbook
Dim wsDest As Worksheet
Dim wsCopy As Worksheet
Dim DestLastRow As Long
Dim CopyLastRow As Long
Application.ScreenUpdating = False
Set Template = ActiveWorkbook
Set wsDest = ThisWorkbook.Worksheets("Site prep")
'copy of original lastrows
'DestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
'CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
'named wb
Dim wbNames As String
wbNames = "Discrep"
For Each wb In Workbooks
If wb.Name Like wbNames & "*" Then Set nData = wb
If wb.Name Like wbNames & "*" Then
'any wb
'For Each wb In Workbooks
'If wb.Name <> ThisWorkbook.Name Then Set nData = wb
'If wb.Name <> ThisWorkbook.Name Then
Application.ScreenUpdating = False
Set wsCopy = nData.Sheets("RAW")
DestLastRow = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row
nData.Activate
wsCopy.Select
'Insert any formatting/ file prep on what needs to be copied here
CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "N").End(xlUp).Offset(-1).Row
Application.Calculation = xlManual
ActiveSheet.Range("$A$1:$AF$" & CopyLastRow).AutoFilter Field:=16, Criteria1:= _
"AP1 FORECAST"
'https://techcommunity.microsoft.com/discussions/excelgeneral/vba-to-copy-visible-cells-and-paste-as-values-in-another-sheet/3606353
'copy headers
'wsCopy.Range("A1:I1").Copy
'wsDest.Range("B1:J1").PasteSpecial Paste:=xlPasteValues 'Copy headers
'Copy data
wsCopy.Range("M2:U" & CopyLastRow).SpecialCells(xlCellTypeVisible).Copy
wsDest.Range("A" & DestLastRow).PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = False
nData.Close
Application.DisplayAlerts = True
End If
Application.Calculation = xlAutomatic
Next wb
End Sub
here is another one i built with a few changes
Sub C_Forcast_Editing_Transfer()
Dim wb As Workbook
Dim nData As Workbook
Dim Template As Workbook
Dim wsDest As Worksheet
Dim wsCopy As Worksheet
Dim DestLastRow As Long
Dim CopyLastRow As Long
Application.ScreenUpdating = False
Set Template = ActiveWorkbook
Set wsDest = ThisWorkbook.Worksheets("Tab name")
For Each wb In Workbooks
If wb.Name <> ThisWorkbook.Name Then Set nData = wb
If wb.Name <> ThisWorkbook.Name Then
Application.ScreenUpdating = False
Set wsCopy = nData.Sheets(1)
DestLastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
nData.Activate
'https://www.exceldemy.com/excel-vba-delete-columns-based-on-header
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Dim i As Integer
For i = 1 To 400 Step 1
Select Case Cells(1, i).Value
Case "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec", " Total", "Total"
Cells(1, i).EntireColumn.Delete
End Select
Next i
CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Offset(-1).Row
wsCopy.Range("A1:I1").Copy
wsDest.Range("B1:J1").PasteSpecial Paste:=xlPasteValues 'Copy headers
wsCopy.Range("A2:I" & CopyLastRow).Copy
wsDest.Range("B" & DestLastRow).PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = False
nData.Close
Application.DisplayAlerts = True
End If
End If
Next wb
'Any addittional functions with Report file
End Sub
here is another one i put together since i saw that the source file kept having the title misspelled except for 1 word.
Sub E_Misspelled_File_with_Date()
Dim wb As Workbook
Dim nData As Workbook
Dim Template As Workbook
Dim wsDest As Worksheet
Dim wsCopy As Worksheet
Dim DestLastRow As Long
Dim CopyLastRow As Long
Application.ScreenUpdating = False
Set Template = ActiveWorkbook
Set wsDest = ThisWorkbook.Worksheets("Tab name")
'named wb
Dim wbNames As String
wbNames = "Builder"
For Each wb In Workbooks
If wb.Name Like "*" & wbNames & "*" Then Set nData = wb
If wb.Name Like "*" & wbNames & "*" Then
'any wb
'For Each wb In Workbooks
'If wb.Name <> ThisWorkbook.Name Then Set nData = wb
'If wb.Name <> ThisWorkbook.Name Then
Application.ScreenUpdating = False
Set wsCopy = nData.Sheets(1)
DestLastRow = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row
nData.Activate
'formatting/ file prep
Rows("1:4").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Rows("1:1").Select
Selection.AutoFilter
CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Offset(-1).Row
ActiveSheet.Range("$A$1:$U$" & CopyLastRow).AutoFilter Field:=4, Criteria1:= _
"AP1 FORECAST"
'https://techcommunity.microsoft.com/discussions/excelgeneral/vba-to-copy-visible-cells-and-paste-as-values-in-another-sheet/3606353
'copy headers
'wsCopy.Range("A1:I1").Copy
'wsDest.Range("B1:J1").PasteSpecial Paste:=xlPasteValues 'Copy headers
wsCopy.Range("A2:I" & CopyLastRow).SpecialCells(xlCellTypeVisible).Copy
wsDest.Range("A" & DestLastRow).PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = False
nData.Close
Application.DisplayAlerts = True
End If
Next wb
End Sub
