Consolidate specific sheets from different workbooks into one in sheet - excel

I have a single workbook which is edited by 6-7 different people. There are counts given be each person in the sheet and I am looking for a way where I can merge all the sheets and find the sum of the total count. For eg,
This is the sheet in 1st workbook,
A B c
10 15 10
The sheet in the 2nd workbook,
A B c
7 10 9
And it is similar for all the workbooks. I want the final consolidated one to have the sum of all the values in sheets of each workbook,
A B c
17 25 19
I thought one way to do this is to, put all the excel workbooks into a same folder and use the following code to merge it and then use a macro to count it.
Sub GetSheets()
Path = "C:\Users\username\Downloads\New folder"
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
But for some reason this code is getting executed without any errors but has no effect in the consolidated workbook. It is not merging the sheets of the remaining workbooks.
Can anybody tell me what is the error I am making here?
Also is there any alternate way to find the consolidated sum?
thanks

Asuming you still want to go with DIR (you need to input checks for name if there are also other files inside the folder)
Tested it at my pc and it worked perfectly:
Sub SumWB()
Dim Arr(2) As Long, MyWB As Workbook, fStr as String
Const Folder = "C:\NewFolder\"
fStr = Dir(Folder)
While (file <> "")
Set MyWB = Workbooks.Open(Folder & fStr, , True)
Arr(0) = Arr(0) + MyWB.Sheets(1).Range("A1").Value
Arr(1) = Arr(1) + MyWB.Sheets(1).Range("B1").Value
Arr(2) = Arr(2) + MyWB.Sheets(1).Range("C1").Value
MyWB.Close
file = Dir
Wend
Debug.Print Arr(0) & " - " & Arr(1) & " - " & Arr(2)
End Sub

If you are executing the vba code in an excel sheet which is in the same path(folder) as that of the sheets you want to combine ,this would happen.
Try executing the vba in a new excel workbook.

Related

Copy non adjacent data cells into one workbook

this is the code that i am currently using right now, but its not enough to meet my objectives and i am stuck on how to continue....
So this code will copy the specified data from many other excel workbook in the form of xlsx into a main excel workbook and before that it will scan through the folder which contains all the different data files and the main file(all files supposed to be transfered here in a table form) e.g. Test3.xlsx,Test4.xlsx,Test.xlxs and Main.xlsm in the folder of ScanFiles. so everytime a new files comes into the folder, it will automatically update the main workbook by opening the data workbooks then copy the required data and paste it on the main workbook upon clicking a button.
Sub ScanFiles()
Dim myFile As String, path As String
Dim erow As Long, col As Long
path = "c:\Scanfiles\"
myFile = Dir(path & "*.xlsx")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
Set copyrange = Sheets("sheet1").Range("A18,B18,C18,D18,A19,B19,C19,D19")
Windows("master-wbk.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
cel.Copy
Cells(erow, col).PasteSpecial xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Objectives: 1st:orignal type of file is in "file" not xlsx, so hope to find a way to open the file in xlsx format automatically before start of copying data.
2nd: requires 3 types of specified data e.g. name,surname(both of them are in fixed position always in A18 to D18 and A19 to D19 , 3rd one is to find the date, however the date is almost always in different positions in the data sheet, so i hope to add on a part to the code that makes it search for something like "ended 20190808" it will always start with ended but will always be in diff rows or even columns. i also need to arrange the data according to the date from newest(top) to oldest(bottom) and state the month of the date in words instead of numbers e.g. june
Deeply Appreciate any form of help but if possible the small section of code that can add on to my coding will make it a lot easier because im tasked to do this in a very limited amount of time
Thank you!!!
Here's some code that does similar things to what you describe. The animated .gif shows it working by stepping through the code. First the 2 data (.xlsx) files are shown so you have an idea of their content. Each is located in the same folder as the main workbook and has data in column A. Then as we step through the code each file is opened, its data manipulated (row 3 is deleted) and transferred into adjacent columns of the main workbook. The code is not limited to .xlsx files and will work with text files as well, as long as ext is defined.
Hopefully, once you understand how this works you can modify it to apply it to your case.
Option Explicit
Sub CombineFiles()
Dim theDir As String, numFiles As Integer
Dim sh As Worksheet, wk As Workbook, newSheet As Worksheet
Dim newColumn As Range, r As Range, s As String
Const ext = ".xlsx"
Err.Clear
theDir = ThisWorkbook.Path
Set newSheet = ThisWorkbook.Sheets.Add
newSheet.Name = "Combined"
Set newColumn = newSheet.Range("A1")
'Loop through all files in directory
s = Dir(theDir & "\*" & ext)
While s <> ""
numFiles = numFiles + 1
On Error Resume Next
Set wk = Workbooks.Open(theDir & "\" & s)
Set sh = ActiveSheet
sh.Rows(3).Delete Shift:=xlUp
Set r = Range("A1")
Range(r, r.End(xlDown)).Copy
newSheet.Activate
newColumn.Offset(0, numFiles) = wk.Name
newColumn.Offset(1, numFiles).Select
newSheet.Paste
Application.DisplayAlerts = False
wk.Close False
Application.DisplayAlerts = True
s = Dir()
Wend
MsgBox (numFiles & " files were processed.")
End Sub
For copy/paste of pictures see examples on this or this page. To find the last cell containing data in a column see this page; note that one example involves using the .find command. More generally, to learn how to use .find in vba, use the macro recorder and then adjust the resulting code.

How to check if a range contains a word?

I have 3 Excel files that have in the column B the comments: ok or check. Column C contains the product numbers of the products that are either ok or need to be checked. I want to create a list (an overview) in another Excel file (4) of all the products that have the word "check" in column B in the other three Excel files (1,2,3).
I cannot use a pivot table in the three excels because it has to be refreshed manually.
Filter is also not an option. I would like to use VBA/Macros in Excel.
Excel 1
Status Product number
check 1254968
ok 5541485
check 2153654
ok 4588999
ok 8954668
ok 6945665
check 7469968
check 6665448
Excel 2
Status Product number
ok 7455561
ok 5145684
ok 4589666
check 4896471
check 1117347
check 5656478
ok 5256488
Excel 3
Status Product number
ok 3389741
check 6754889
check 1489798
ok 6489646
Excel 4
Products to check
1254968
2153654
7469968
6665448
4896471
1117347
5656478
6754889
1489798
I expect to have a list with all the product numbers that need to be checked in my 4th. Excel.
Create a new workbook in the same folder as the other files are located. Please consider to move away any other .xlsx files before running this macro :) If you need to run it in a specific folder and you are not able to move the files, please include a condition based on the name of the files that you do want to use. Otherwise, the below should be sufficient. Please read all comments in the code.
Sub test()
Dim wb1, wb2 As Workbook
Dim HeadSet As Boolean
Set wb1 = ThisWorkbook
FolderName = "your/path/" 'full path name to folder where xlsx is located
file_name = Dir(FolderName & "*" & ".xlsx", vbDirectory) 'assuming the files are all .xlsx
HeadSet = False 'for fun
'for each file in FolderName
Do While Right(file_name, 5) = ".xlsx" And file_name <> ""
'open workbook
Set wb2 = Workbooks.Open(file_name, False, True)
With wb2.Sheets(1)
For i = .Range("B1").End(xlDown).Row To .Range("B20000").End(xlUp).Row 'change .sheets(1) 1 = index to > your index, or "sheetname"
If LCase(Trim(.Range("B" & i).Value)) = "check" Then 'checks lowercase, so condition should be lower
'create headers in output sheet
If HeadSet = False Then
wb1.Sheets(1).Range("A1").Value = "Products"
wb1.Sheets(1).Range("A1").Value = "Result of check"
HeadSet = True
End If
'change wb1.sheets(index) to your index, or the sheet name between ""
wb1.Sheets(1).Range("A" & wb1.Sheets(1).Range("A20000").End(xlUp).Row + 1).Value = .Range("C" & i).Value
wb1.Sheets(1).Range("B" & wb1.Sheets(1).Range("A20000").End(xlUp).Row + 1).Value = .Range("B" & i).Value
End If
Next i 'next iteration
End With
wb2.Close False 'close workbook
file_name = Dir 'go to next file
Loop
End Sub

Copying a worksheet to multiple other sheets - object issues?

I'm a beginner to VBA and I'm trying copy and paste a sheet from 1 workbook to multiple other workbooks. The latter workbooks have basically the same file name (increasing by 1). All the workbooks are currently open
I keep getting an error saying "Object variable or With block variable not set". But I can't see why the way I declared 'names' or 'wb' is wrong.
I've seen a lot of posts online iterate through open workbooks, but I can't do this because I'm copying something from one of the open workbooks.
Sub CopyWorkbook()
Dim i As Integer, s As String
Dim sh As Workbook, wb As Workbook, names As Worksheet
Set sh = Workbooks("schools.xlsx")
Set names = sh.Sheets("name")
For i = 6 To 15
If i <= 8 Then
s = "0" & i & "-0" & (i + 1) & "-_Year_data"
ElseIf i = 9 Then
s = "0" & i & "-" & (i + 1) & "-_Year_data"
Else
s = i & "-" & (i + 1) & "-_Year_data"
End If
Set wb = Workbooks(s & ".csv")
The error occurs in the first line here:
names.Copy After:=wb.Sheets(wb.Sheets.Count)
Next i
End Sub
Any help/links to tutorials that can help would be greatly appreciated!
I've seen a lot of posts online iterate through open workbooks, but I can't do this because I'm copying something from one of the open workbooks.
You could just add an if
For each wb in workbooks
IF Not wb.name = thisworkbook.name and wb.name <> "schools.xlsx" then
Workbooks("schools.xlsx").Sheets("name").copy _
after := wb.sheets(wb.worksheets.count)
End IF
Next wb
around your code to allow you to loop through all open workbooks, except the one hosting the code
EDIT: I've just noticed you're dealing with csv files, so they only have a single sheet anyway.

Copying base data sheet along with selected sheets from source workbook to new workbook

I am looking at building a master workbook which receives a monthly dump of data for all Cost Centres which will then populate a large number of worksheets within the workbook, and which then need to be split off and sent out to service heads. A service head will receive a selection of worksheets based on the first 4 characters of the sheet name (although this may change in due course).
eg 1234x, 1234y, 5678a, 5678b will produce two new workbooks named 1234 and 5678 with two sheets in each.
I have cobbled some code from various forum to create a macro that will work through a hard coded array defining the service head 4 character codes and create a series of new workbooks. And which seems to work.
However.. I also need to include the main data dump sheet within the source file (called "data") with the the array of files being copied over so that the links remain with the data sheet being copied over. If I write a line to copy over the data sheet separately, the new workbook still refers back to the source file, which service heads do not have access to.
So main question is: how can I add the "data" tab into the Sheets(CopyNames).Copy code so it is copied over with all the other files in the array at the same to keep the links intact?
Second question is if I decide it is the first two characters of the worksheet define the sheets that relate to a service head, how do I tweak the split/mid line of code - I've trialled around but am getting tied up in knots!
Any other tips to make the code more elegant much appreciated (there may be quite a long list of service head codes and I am sure there is a better way of creating a list for the routine to loop through)
Sub Copy_Sheets()
Dim strNames As String, strWSName As String
Dim arrNames, CopyNames
Dim wbAct As Workbook
Dim i As Long
Dim arrlist As Object
Set arrlist = CreateObject("system.collections.arraylist")
arrlist.Add "1234"
arrlist.Add "5678"
Set wbAct = ActiveWorkbook
For Each Item In arrlist
For i = 1 To Sheets.Count
strNames = strNames & "," & Sheets(i).Name
Next i
arrNames = Split(Mid(strNames, 2), ",")
'strWSName =("1234")
strWSName = Item
Application.ScreenUpdating = False
CopyNames = Filter(arrNames, strWSName, True, vbTextCompare)
If UBound(CopyNames) > -1 Then
Sheets(CopyNames).Copy
ActiveWorkbook.SaveAs Filename:=strWSName & " " & Format(Now, "dd-mmm-yy h-mm-ss")
ActiveWorkbook.Close
wbAct.Activate
Else
MsgBox "No sheets found: " & strWSName
End If
Next Item
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub CopySheets()
With ThisWorkbook
Dim SheetIndex As Long
Dim ValidSheetNames() As String
ReDim ValidSheetNames(1 To .Worksheets.Count)
' Build a 1 dimensional array called ValidSheetNames, which contains every sheet in the master workbook other than DEDICATEDSHEET. '
Dim ws As Worksheet
For Each ws In .Worksheets
If ws.Name <> "DEDICATEDSHEET" Then
SheetIndex = SheetIndex + 1
ValidSheetNames(SheetIndex) = ws.Name
End If
Next ws
ReDim Preserve ValidSheetNames(1 To SheetIndex)
' Read all ServiceCodes into a 1-dimensional array '
Dim ServiceHeadCodes As Variant
ServiceHeadCodes = Application.Transpose(.Worksheets("DEDICATEDSHEET").Range("CCLIST[CC]").Value2)
Dim CodeIndex As Long
' Now loop through each ServiceHeadCode '
For CodeIndex = LBound(ServiceHeadCodes) To UBound(ServiceHeadCodes)
' Put all sheet names which contain the current ServiceHeadCode into an array called SheetsToCopy '
Dim SheetsToCopy() As String
SheetsToCopy = Filter(ValidSheetNames, ServiceHeadCodes(CodeIndex), True, vbTextCompare)
' Check if SheetToCopy now contains any sheet names at all. '
If UBound(SheetsToCopy) > -1 Then
' Add the name of the Data sheet to the end of the array '
ReDim Preserve SheetsToCopy(LBound(SheetsToCopy) To (UBound(SheetsToCopy) + 1))
SheetsToCopy(UBound(SheetsToCopy)) = "Data"
Dim OutputWorkbook As Workbook
Set OutputWorkbook = Application.Workbooks.Add
' Copy all sheets which are in SheetToCopy array to newly created OutputWorkbook '
.Worksheets(SheetsToCopy).Copy OutputWorkbook.Worksheets(1)
' Delete the default Sheet1, which should be at the end as copied sheets were inserted before it. '
' But suppress the Are you sure you want to delete this sheet.. message. '
Application.DisplayAlerts = False
OutputWorkbook.Worksheets(OutputWorkbook.Worksheets.Count).Delete
Application.DisplayAlerts = True
' Re-enable alerts, as we want to see any other dialogue boxes/messages
' Not providing a full directory path below means OutputWorkbook will be saved wherever Thisworkbook is saved.'
OutputWorkbook.SaveAs Filename:=ServiceHeadCodes(CodeIndex) & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".xlsx", FileFormat:=51
OutputWorkbook.Close
Else
MsgBox "No sheets found: " & ServiceHeadCodes(CodeIndex)
End If
Next CodeIndex
End With
End Sub
Untested and written on mobile, sorry for bad formatting.
This approach proposes that you store all service head codes in a 1-column Excel table on a dedicated sheet that is referred to via Excel table nomenclature (which might be easier than ArrayList.Add for each new service head code).
I assume code is stored in master workbook ('thisworkbook'), which might not be true.
You could modify the serviceheadcodes table directly on the spreadsheet itself, if you later decide that SheetsToCopy will be determined by first 2, 3 or X characters -- or you could modify array itself with left$() function.
Hope it works or gives you some ideas.
Edit: This is my sheet and table layout (which I assume matches yours).
And this is what the code above gives me on my computer.

excel vba vlookup referencing separate workbook without name

I want a code in one workbook that uses vlookup to reference another workbook without specific identification.
So I have to use vlookup almost every month for about 20 different reports and I want to automate it, but because the names and every other type of information is different, I cannot use names or indexes.
I checked other posts and mainly the answers that I've seen were ones that referenced a name or instead of a name, an index. Because the names are going to be different every time I won't be able to reference to them, it won't be an automated process. I was thinking about looking for some reference like "ActiveWorkbook." The "ActiveWorkbook" reference only targets one workbook however there is one workbook where the data is going to be inputted and one workbook where the source data is.
I believe your problem is that you have started looking for useful pieces of code before learning the basics. This is a very common problem and many are in much worse shape than you. There are many online Excel VBA tutorials. Try a few; find one that matches your learning style and finish it. I prefer books to online tutorials. I visited a large library; reviewed their Excel VBA primers; borrowed the most promised; completed my review at home and bought the one I liked best as a permanent reference.
I need you to pick a folder containing at least three workbooks which I will call workbooks A, B and C. Workbook A must be macro enabled and must have a reference to the Microsoft Runtime Scripting library. At least one workbook should have multiple worksheets. At least one worksheet should have values in row 1.
Copy DemoWbkWsht to a new module in workbook A. In line 49 replace "SheetsMove.xlsm" with the name of workbook C.
Open workbook B. Go to “Run macros” and run macro DemoWbkWsht. That is, run a macro in another workbook. Macro DemoWbkWsht creates a file named “DemoWbkWsht.txt” in the folder. Work down the file and the macro reviewing the output and the statements I used to create that output. I believe I have demonstrated everything you need to know. Come back with questions as necessary but, the more you can understand on your own, the faster you will develop.
The points I particularly want you to notice:
The difference between ActiveWorkbook and ThisWorkbook
Workbooks.Open changes ActiveWorkbook but not ThisWorkbook.
How you can loop through the open workbooks or create an array of
workbook references and loop through them.
How you can loop through every worksheet in a workbook.
How every workbook has an ActiveSheet. This is the worksheet activate when the workbook was last saved. That was why I asked if these workbooks had more than one worksheet. If a workbook has only one worksheet, that worksheet must be the active worksheet.
How you can look at any cell within any worksheet within any open workbook. I have used this ability to list the values in row 1 of every worksheet. These values are column headings in most worksheets. This was my other question: can you identify the target worksheet by its headings? I doubt you need the user’s help, I believe your macro can identify the worksheets you need to access itself.
Good luck
Option Explicit
Sub DemoWbkWsht()
' Needs reference to Microsoft Scripting Runtime library. See Tools->References.
Dim ColCrnt As Long
Dim ColLast As Long
Dim DiagFile As TextStream
Dim Fso As New FileSystemObject
Dim InxWbk As Long
Dim InxWsht As Long
Dim Path As String
Dim WbkA As Workbook
Dim WbkB As Workbook
Dim WbkC As Workbook
Dim WbkCrnt As Variant
' Updating the screen while updating a worksheet is the easiest way of
' ensuring your macro takes FOREVER to run. ALWAYS include this statement
' even if you do not think it is necessary.
Application.ScreenUpdating = False
' Create reference to workbook holding this macro
Set WbkA = ThisWorkbook
' Record path of workbook holding macro.
Path = ThisWorkbook.Path & "\"
' Create the text file to which diagnostic file will be output within
' the folder holding the workbook holding this macro
Set DiagFile = Fso.CreateTextFile(Path & "DemoWbkWsht.txt", True, False)
' List open workbooks. Identify workbook B.
DiagFile.WriteLine "***** Workbooks open when macro started"
For InxWbk = 1 To Workbooks.Count
DiagFile.WriteLine " " & Workbooks(InxWbk).Name
If Workbooks(InxWbk).Name <> WbkA.Name Then
Set WbkB = Workbooks(InxWbk)
End If
Next
' List special workbooks.
DiagFile.WriteLine "***** Special workbooks"
DiagFile.WriteLine " ActiveWorkbook: " & ActiveWorkbook.Name
DiagFile.WriteLine " ThisWorkbook: " & ThisWorkbook.Name
DiagFile.WriteLine " Workbook A: " & WbkA.Name
DiagFile.WriteLine " Workbook B: " & WbkB.Name
Set WbkC = Workbooks.Open(Filename:=Path & "SheetsMove.xlsm")
DiagFile.WriteLine "***** Special workbooks after open of workbook C."
DiagFile.WriteLine " ActiveWorkbook: " & ActiveWorkbook.Name
DiagFile.WriteLine " ThisWorkbook: " & ThisWorkbook.Name
DiagFile.WriteLine " Workbook A: " & WbkA.Name
DiagFile.WriteLine " Workbook B: " & WbkB.Name
DiagFile.WriteLine " Workbook C: " & WbkC.Name
' List worksheets in workbooks A, B and C
For Each WbkCrnt In VBA.Array(WbkA, WbkB, WbkC)
With WbkCrnt
DiagFile.WriteLine "***** Worksheets in workbook """ & .Name & """"
With WbkCrnt
For InxWsht = 1 To .Worksheets.Count
DiagFile.WriteLine PadL(InxWsht, 4) & " " & .Worksheets(InxWsht).Name
Next
DiagFile.WriteLine " ActiveWorksheet: " & .ActiveSheet.Name
End With
End With
Next
' List worksheets in workbooks A, B and C
For Each WbkCrnt In VBA.Array(WbkA, WbkB, WbkC)
With WbkCrnt
DiagFile.WriteLine "***** Worksheets in workbook """ & .Name & """"
For InxWsht = 1 To .Worksheets.Count
DiagFile.WriteLine PadL(InxWsht, 4) & " " & .Worksheets(InxWsht).Name
Next InxWsht
DiagFile.WriteLine " ActiveSheet: " & .ActiveSheet.Name
End With ' WbkCrnt
Next WbkCrnt
' List values from row 1 of worksheets in workbooks A, B and C
For Each WbkCrnt In VBA.Array(WbkA, WbkB, WbkC)
With WbkCrnt
DiagFile.WriteLine "***** Values, if any, from row 1 of each worksheet in workbook """ & .Name & """"
For InxWsht = 1 To .Worksheets.Count
With .Worksheets(InxWsht)
DiagFile.WriteLine PadL(InxWsht, 4) & " Worksheet: " & .Name
ColLast = .Cells(1, .Columns.Count).End(xlToLeft).Column
For ColCrnt = 1 To ColLast
If .Cells(1, ColCrnt).Value <> "" Then
DiagFile.WriteLine Space(5) & ColCode(ColCrnt) & "1=" & .Cells(1, ColCrnt).Value
End If
Next ColCrnt
End With ' .Worksheets(InxWsht)
Next InxWsht
End With ' WbkCrnt
Next WbkCrnt
WbkC.Close SaveChanges:=False
DiagFile.Close
Application.ScreenUpdating = True
End Sub
Function ColCode(ByVal ColNum As Long) As String
Dim PartNum As Long
' 3Feb12 Adapted to handle three character codes.
' 28Oct16 Renamed ColCode to match ColNum.
If ColNum = 0 Then
Debug.Assert False
ColCode = "0"
Else
ColCode = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
ColCode = Chr(65 + PartNum) & ColCode
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
End Function
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with leading PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Sep15 Coded
' 20Dec15 Added code so overlength strings are not truncated
' 10Jun16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadL = Str
Else
PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
End If
End Function

Resources