Scribd
Upload
17 views4 pages

Extract Data from Multiple Workbooks

This VBA code extracts data from multiple Excel workbooks into consolidated sheets in a destination workbook. It loops through an array of workbook names, opens each workbook, copies data from specific sheets to new sheets based on column filters or full sheet copies, and updates the destination row counters.

Uploaded by

Tarunvd03
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
17 views4 pages

Extract Data from Multiple Workbooks

This VBA code extracts data from multiple Excel workbooks into consolidated sheets in a destination workbook. It loops through an array of workbook names, opens each workbook, copies data from specific sheets to new sheets based on column filters or full sheet copies, and updates the destination row counters.

Uploaded by

Tarunvd03
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd

Sub ExtractAllDataFromAllWorkbooks()

Dim wsDestinationPOS As Worksheet


Dim wsDestinationCancelled As Worksheet
Dim wsDestinationRCMITC As Worksheet
Dim wsDestinationITC3BNotFiled As Worksheet
Dim wsDestinationB2B As Worksheet
Dim folderPath As String
Dim fileName As String
Dim currentWorkbook As Workbook
Dim isFirstSet As Boolean

' Define constants for readability


Const POS_SHEET As String = "POS"
Const CANCELLED_SHEET As String = "Cancelled"
Const RCMITC_SHEET As String = "RCM"
Const ITC3BNOTFILED_SHEET As String = "3B-N"
Const B2B_SHEET As String = "WM"

' Get the path of the current workbook


folderPath = [Link]

' Create new sheets for consolidated data


Set wsDestinationPOS = CreateNewSheet(POS_SHEET)
Set wsDestinationCancelled = CreateNewSheet(CANCELLED_SHEET)
Set wsDestinationRCMITC = CreateNewSheet(RCMITC_SHEET)
Set wsDestinationITC3BNotFiled = CreateNewSheet(ITC3BNOTFILED_SHEET)
Set wsDestinationB2B = CreateNewSheet(B2B_SHEET)

' Initialize the starting point for each sheet


Dim destinationRows As Collection
Set destinationRows = New Collection
[Link] 1, POS_SHEET
[Link] 1, CANCELLED_SHEET
[Link] 1, RCMITC_SHEET
[Link] 1, ITC3BNOTFILED_SHEET
[Link] 1, B2B_SHEET

isFirstSet = True

' Array of workbook names to loop through


Dim workbookNames As Variant
workbookNames = Array("17-18_DS", "18-19_DS", "19-20_DS", "20-21_DS", "21-
22_DS", "22-23_DS")

' Loop through each source workbook in the folder


Dim i As Integer
For i = LBound(workbookNames) To UBound(workbookNames)
fileName = folderPath & "\" & workbookNames(i) & ".xlsx"
If Dir(fileName) <> "" Then
Set currentWorkbook = [Link](fileName)
ProcessWorkbook currentWorkbook, wsDestinationPOS,
wsDestinationCancelled, wsDestinationRCMITC, wsDestinationITC3BNotFiled,
wsDestinationB2B, destinationRows, isFirstSet
[Link] SaveChanges:=False
End If
Next i

' Remove blank rows in all destination sheets


RemoveBlankRows wsDestinationPOS
RemoveBlankRows wsDestinationCancelled
RemoveBlankRows wsDestinationRCMITC
RemoveBlankRows wsDestinationITC3BNotFiled
RemoveBlankRows wsDestinationB2B
End Sub

Function CreateNewSheet(sheetName As String) As Worksheet


Dim ws As Worksheet
Set ws = [Link](After:=Sheets([Link]))
[Link] = sheetName
Set CreateNewSheet = ws
End Function

Sub ProcessWorkbook(currentWorkbook As Workbook, wsDestinationPOS As Worksheet,


wsDestinationCancelled As Worksheet, wsDestinationRCMITC As Worksheet,
wsDestinationITC3BNotFiled As Worksheet, wsDestinationB2B As Worksheet,
destinationRows As Collection, ByRef isFirstSet As Boolean)
Dim wsComplete As Worksheet
Dim lastRow As Long
Dim destinationRowPOS As Long
Dim destinationRowCancelled As Long
Dim destinationRowRCMITC As Long
Dim destinationRowITC3BNotFiled As Long
Dim destinationRowB2B As Long

' Update destination rows


destinationRowPOS = destinationRows(POS_SHEET)
destinationRowCancelled = destinationRows(CANCELLED_SHEET)
destinationRowRCMITC = destinationRows(RCMITC_SHEET)
destinationRowITC3BNotFiled = destinationRows(ITC3BNOTFILED_SHEET)
destinationRowB2B = destinationRows(B2B_SHEET)

' Process "Complete 2A" sheet if it exists


On Error Resume Next
Set wsComplete = [Link]("Complete 2A")
On Error GoTo 0

If Not wsComplete Is Nothing Then


If Not isFirstSet Then
destinationRowPOS = destinationRowPOS + 2 ' Add 2 blank rows between
different sets of data
destinationRowCancelled = destinationRowCancelled + 2
destinationRowRCMITC = destinationRowRCMITC + 2
destinationRowITC3BNotFiled = destinationRowITC3BNotFiled + 2
destinationRowB2B = destinationRowB2B + 2
Else
isFirstSet = False
End If

AddWorkbookTitle wsDestinationPOS, destinationRowPOS, [Link]


AddWorkbookTitle wsDestinationCancelled, destinationRowCancelled,
[Link]
AddWorkbookTitle wsDestinationRCMITC, destinationRowRCMITC,
[Link]
AddWorkbookTitle wsDestinationITC3BNotFiled, destinationRowITC3BNotFiled,
[Link]
AddWorkbookTitle wsDestinationB2B, destinationRowB2B, [Link]

' Filter and copy data based on the "POS" criterion (column R <> 7)
CopyFilteredData wsComplete, wsDestinationPOS, 18, "<>7", destinationRowPOS

' Filter and copy data based on the "Cancelled" criterion (column E not
empty)
CopyFilteredData wsComplete, wsDestinationCancelled, 5, "<>",
destinationRowCancelled
End If

' Process "RCM ITC" sheet if it exists


On Error Resume Next
Set wsRCMITC = [Link]("RCM ITC")
On Error GoTo 0

If Not wsRCMITC Is Nothing Then


CopySheetData wsRCMITC, wsDestinationRCMITC, destinationRowRCMITC
End If

' Process "ITC - 3B Not Filed" sheet if it exists


On Error Resume Next
Set wsITC3BNotFiled = [Link]("ITC - 3B Not Filed")
On Error GoTo 0

If Not wsITC3BNotFiled Is Nothing Then


CopySheetData wsITC3BNotFiled, wsDestinationITC3BNotFiled,
destinationRowITC3BNotFiled
End If

' Process "B2B" sheet if it exists


On Error Resume Next
Set wsB2B = [Link]("B2B")
On Error GoTo 0

If Not wsB2B Is Nothing Then


CopyFilteredData wsB2B, wsDestinationB2B, 17, "Wrong Month",
destinationRowB2B
End If

' Update the collection with the new rows


[Link] POS_SHEET
[Link] CANCELLED_SHEET
[Link] RCMITC_SHEET
[Link] ITC3BNOTFILED_SHEET
[Link] B2B_SHEET

[Link] [Link]([Link],
"A").End(xlUp).Row + 1, POS_SHEET
[Link]
[Link]([Link], "A").End(xlUp).Row
+ 1, CANCELLED_SHEET
[Link] [Link]([Link],
"A").End(xlUp).Row + 1, RCMITC_SHEET
[Link]
[Link]([Link],
"A").End(xlUp).Row + 1, ITC3BNOTFILED_SHEET
[Link] [Link]([Link],
"A").End(xlUp).Row + 1, B2B_SHEET
End Sub

Sub AddWorkbookTitle(ws As Worksheet, ByRef destinationRow As Long, workbookName As


String)
[Link](destinationRow, 1).Value = "Workbook: " &
GetFileNameWithoutExtension(workbookName)
[Link](destinationRow, 1).[Link] = True
destinationRow = destinationRow + 1
End Sub

Sub CopyFilteredData(sourceSheet As Worksheet, destSheet As Worksheet, filterField


As Integer, filterCriteria As String, ByRef destinationRow As Long)
Dim lastRow As Long
lastRow = [Link]([Link], "A").End(xlUp).Row
[Link](1).AutoFilter Field:=filterField, Criteria1:=filterCriteria
If [Link](103, [Link](1)) > 1 Then
[Link]("2:" &
lastRow).SpecialCells(xlCellTypeVisible).[Link]
Destination:=[Link](destinationRow + 1)
End If
[Link] = False
End Sub

Sub CopySheetData(sourceSheet As Worksheet, destSheet As Worksheet, ByRef


destinationRow As Long)
Dim lastRow As Long
lastRow = [Link]([Link], "A").End(xlUp).Row
[Link]("1:" & lastRow).Copy
Destination:=[Link](destinationRow + 1)
destinationRow = destinationRow + lastRow
End Sub

Sub RemoveBlankRows(ws As Worksheet)


On Error Resume Next
[Link](xlCellTypeBlanks).[Link]
On Error GoTo 0
End Sub

Function GetFileNameWithoutExtension(fullFileName As String) As String


Dim fileName As String
fileName = Left(fullFileName, InStrRev(fullFileName, ".") - 1)
GetFileNameWithoutExtension = fileName
End Function

You might also like