Created
July 29, 2017 18:38
-
-
Save sidharthkuruvila/996004fd12037532c252ecce1cba5b1e to your computer and use it in GitHub Desktop.
vba excel macro script that aggregates data from multiple xlsx files
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'vba excel macro script that aggregates data from multiple xlsx files. | |
'The path to the directory containing the files should be in a sheet called | |
'Control. And should be in Applescripts colon (:) separated format. | |
Option Explicit | |
Const max_rows As Integer = 200 | |
Sub ListFiles() | |
Const merge_sheet_name As String = "Merge Sheet" | |
Dim sh As Worksheet | |
Dim DestSalesSh As Worksheet | |
Dim DestSalesIdx As Integer | |
Dim DestExpencesSh As Worksheet | |
Dim DestExpencesIdx As Integer | |
Dim FolderPath As String | |
Dim FilePath As String | |
Dim FullFilePath As String | |
Dim wkb As Workbook | |
DestSalesIdx = 1 | |
DestExpencesIdx = 1 | |
Set DestSalesSh = RecreateWorksheet("Sales") | |
Set DestExpencesSh = RecreateWorksheet("Expences") | |
FolderPath = ActiveWorkbook.Sheets("Control").Cells(2, 2) | |
FilePath = Dir(FolderPath) | |
Do Until Len(FilePath) < 1 | |
FullFilePath = FolderPath & FilePath | |
If Not (EndsWith(FilePath, "xlsx")) Then GoTo ContinueDoLoop | |
Set wkb = Workbooks.Open(FullFilePath) | |
LoadSheetsFromFile DestSh:=DestSalesSh, wkb:=wkb, DestIdx:=DestSalesIdx, StartCol:=1 | |
LoadSheetsFromFile DestSh:=DestExpencesSh, wkb:=wkb, DestIdx:=DestExpencesIdx, StartCol:=3 | |
wkb.Close savechanges:=False | |
ContinueDoLoop: | |
FilePath = Dir() | |
Loop | |
End Sub | |
Sub LoadSheetsFromFile(DestSh As Worksheet, wkb As Workbook, ByRef DestIdx As Integer, StartCol As Integer) | |
Dim DateValue As Range | |
Dim sh As Worksheet | |
Dim i As Integer | |
For Each sh In wkb.Worksheets | |
If sh.name <> DestSh.name Then | |
Set DateValue = sh.Cells(1, 5) | |
For i = 2 To max_rows | |
If sh.Cells(i, StartCol) <> "" And Not (sh.Cells(i, 1).HasFormula) Then | |
DestSh.Cells(DestIdx, 1) = DateValue | |
DestSh.Cells(DestIdx, 2) = sh.Cells(i, StartCol + 0) | |
DestSh.Cells(DestIdx, 3) = sh.Cells(i, StartCol + 1) | |
DestIdx = DestIdx + 1 | |
End If | |
Next | |
End If | |
Next | |
End Sub | |
Function RecreateWorksheet(name As String) As Worksheet | |
Dim DestSh | |
If sheetExists(name) Then | |
Application.DisplayAlerts = False | |
ActiveWorkbook.Worksheets(name).Delete | |
Application.DisplayAlerts = True | |
End If | |
Set DestSh = ActiveWorkbook.Sheets.Add | |
DestSh.name = name | |
Set RecreateWorksheet = DestSh | |
End Function | |
'Copied from https://stackoverflow.com/questions/6040164/excel-vba-if-worksheetwsname-exists | |
Function sheetExists(sheetToFind As String) As Boolean | |
Dim sheet | |
sheetExists = False | |
For Each sheet In Worksheets | |
If sheetToFind = sheet.name Then | |
sheetExists = True | |
Exit Function | |
End If | |
Next sheet | |
End Function | |
'Copied from http://excelrevisited.blogspot.in/2012/06/endswith.html | |
Public Function EndsWith(str As String, ending As String) As Boolean | |
Dim endingLen As Integer | |
endingLen = Len(ending) | |
EndsWith = (Right(Trim(UCase(str)), endingLen) = UCase(ending)) | |
End Function |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment