Code:
Option Explicit
Sub BringInAllCompletedData()
Call SortAllFiles
Call LoopThroughDirectory
Call UpdateDateInSheet1ColK
Call UpdateOriginalData
Call ClearSheet1
End Sub
'https://www.mrexcel.com/forum/excel-questions/471802-vba-open-file-run-code-close-save-open-next-file.html
Sub SortAllFiles()
Dim folderPath As String
Dim filename As String
Dim wb As Workbook
Application.DisplayAlerts = False
folderPath = ActiveWorkbook.Path & "\" 'change to suit
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & filename)
'Call a subroutine here to operate on the just-opened workbook
If filename = "zmaster.xlsm" Then
Exit Sub
Else
Call SortSheet1InAllFiles
End If
filename = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub SortSheet1InAllFiles()
Dim MyFile As String
Dim eRow As Long
Dim RowsConsolidated As Long
Dim LastRow As Long
Dim i As Long
eRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Cells.Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("K2:K" & eRow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:N" & eRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Save
Range("A1").Select
ActiveWorkbook.Close
End Sub
'http://www.exceltrainingvideos.com/transfer-data-multiple-workbooks-master-workbook-automatically/
Sub LoopThroughDirectory()
Dim MyFile As String
Dim eRow As Long
Dim LRL As Long
Dim LRK As Long
Dim i As Long
Dim FilePath As String
FilePath = ActiveWorkbook.Path & "\"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Sheet1").Activate
MyFile = Dir(FilePath)
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Workbooks.Open (FilePath & MyFile)
LRK = Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).Row 'Column L
LRL = Cells(Rows.Count, 12).End(xlUp).Offset(1, 0).Row 'Column K
For i = LRL To LRK
Range("A" & LRL & " : " & "K" & LRK).Copy
Next
ActiveWorkbook.Close
eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(eRow, 1), Cells(eRow, 11))
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Workbooks.Open (FilePath & MyFile)
For i = LRL To LRK - 1
If Range("L" & i).Value = "" Then
Range("L" & i).Value = Date
Columns("L:L").NumberFormat = "[$-C09]dd-mmm-yy;@"
End If
Next
Range("A1").Select
ActiveWorkbook.Save
ActiveWorkbook.Close
MyFile = Dir
ActiveWorkbook.Save
Loop
Columns("A:D").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A" & eRow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:D" & eRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub UpdateDateInSheet1ColK()
Dim eRow As Long
Dim i As Long
Sheets("Sheet1").Activate
eRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For i = 2 To eRow
If Range("K" & i) <> "" Then
Range("L" & i).Value = Format(Date, "dd/mmm/yyyy")
End If
Next
End Sub
'https://www.youtube.com/watch?v=AzhQ5KiNybk
Sub UpdateOriginalData()
Dim i As Integer
Dim j As Integer
Dim LastRow1 As Integer
Dim LastRow2 As Integer
Dim SNo As Double
LastRow1 = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
LastRow2 = Sheets("OriginalData").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow1
SNo = Sheets("Sheet1").Cells(i, "A").Value
Sheets("OriginalData").Activate
For j = 2 To LastRow2
If Sheets("OriginalData").Cells(j, "A").Value = SNo Then
Sheets("Sheet1").Activate
Sheets("Sheet1").Range(Cells(i, "G"), Cells(i, "L")).Copy
Sheets("OriginalData").Activate
Sheets("OriginalData").Range(Cells(j, "G"), Cells(j, "L")).Select
ActiveSheet.Paste
End If
Next j
Application.CutCopyMode = False
Next i
Sheets("OriginalData").Activate
Cells.Select
ActiveWorkbook.Save
Selection.Columns.AutoFit
Range("A1").Select
End Sub
Sub ClearSheet1()
Dim eRow As Long
Sheets("Sheet1").Activate
eRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Range("A2:O" & eRow).Select
Selection.ClearContents
Selection.Columns.AutoFit
Range("A1").Select
ActiveWorkbook.Save
End Sub
Thank you for all your suggestions and input. What I have done is a long drawn process. Maybe it can be written into one macro.
Reply With Quote
( Even amongst his colleagues he is still known as a bit of an idiot ( but a confident Pilot I might add )
Originally Posted by RaghavendraPrabhu
Bookmarks