Re: Sum Up Numbers From Multiple Workbooks
Hi you can try this
This is only example but you can change some lines of code and i think it will work for you
Code
Option Explicit
'32-bit API declarations
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Function GetDirectory() As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.ulFlags = &H1 ' Type of directory to return
x = SHBrowseForFolder(bInfo) ' Display the dialog
path = Space$(512) ' Parse the result
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub ConsolidateWorkbooks()
Dim s_ChoosenPath As String, strFileName As String
Dim objFSO As Object, objDir As Object
Dim aItem As Variant
Dim wks_ParentWorkbook As Workbook, wks_OtherWorkbooks As Workbook
Dim l_LastRow As Long, l_LastRowinMain As Long
s_ChoosenPath = GetDirectory()
' mask of files
strFileName = "*.xl*"
' String is empty = Exit Sub
If Len(s_ChoosenPath) = 0 Then Exit Sub
' If string's missing pathseparator it will be add
If Right(s_ChoosenPath, 1) <> Application.PathSeparator Then
s_ChoosenPath = s_ChoosenPath & Application.PathSeparator
End If
' open all workbooks in choosen path
' (for all verison of Excel)
' create WSH link
Set objFSO = CreateObject("scripting.filesystemobject")
Set objDir = objFSO.GetFolder(s_ChoosenPath)
' The path is empty?
If objDir.Files.Count > 0 Then
Set wks_ParentWorkbook = ActiveWorkbook
For Each aItem In objDir.Files
' is file MS Excel format?
If UCase(aItem.Name) Like UCase(strFileName) Then
' open workbook
Set wks_OtherWorkbooks = Workbooks.Open(Filename:=aItem)
' found out last row in first sheet
l_LastRow = wks_OtherWorkbooks.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
' found out last row in Parent workbook +1
l_LastRowinMain = wks_ParentWorkbook.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
' copy information
Range(Cells(1, "A"), Cells(l_LastRow, "A")).Copy Destination:=wks_ParentWorkbook.Sheets(1).Cells(l_LastRowinMain, "A")
' close workbooks without save changes
wks_OtherWorkbooks.Close SaveChanges:=False
End If
Next aItem
Else
MsgBox Prompt:="Some information", _
Title:="The path doesn't content any MS Excel files", _
Buttons:=vbInformation
End If
MsgBox "Done"
Set objFSO = Nothing: Set objDir = Nothing
Set wks_ParentWorkbook = Nothing: Set wks_OtherWorkbooks = Nothing
End Sub