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
Related
Right now I have a huge spreadsheet that I use to print out commission statements. It's a process of hiding certain columns, filtering through names, and printing a commission statement for each person to pdf. It's not in table or pivot table format, just a large data set with headers for each column. I'm having serious trouble starting and I would love to figure out a macro where it
Hides the columns I don't need (I have this part)
Loops through each name in a specific column and print their statement to pdf to a specific file folder (I would want the user to be able to choose the path file. Maybe with a msgbox prompt)
If possible have it automatically name the file to be the first letter of their first name and the first 2 letters of their last name
Also, I'd like to have error handling to where if I'm filtering through and a name doesn't come up (instead it's blank or 0), to not print that statement.
I don't know how much the following will help but the worksheet name is called "Commission Review" and an example of a column I'd need to filter by is "Storm BSM Name." My headers are on row 39 and the range of data that I'd want filtered would be from D39:CF241.
If anyone could help that would be amazing!! Below is a copy of the code I have so far. I'm having problems with the filtering. I want to use the variable "c" to go through each filter and use that "c" to name the file and loop through each name. So say the first person is John Doe, I'd like to somehow use the filter to name the pdf to be "JDO."
Dim ws As Worksheet
Dim rng As Range
Dim c As Long 'criteria variable
Dim Filename As String 'names of pdfs printed
Dim filedir As String
Dim filetolist As String
Dim Openbook As Workbook
Set ws = ThisWorkbook.Worksheets("Commission Review")
Set rng = ws.Range("$D$39:$CF$239")
'Set folder for where to export files
MsgBox "Select BSM Commissions Statement Destination", vbOKOnly, "Commission Statement Destination"
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.ButtonName = "Pick Folder"
If .Show = 0 Then
MsgBox "Nothing was selected"
Exit Sub
Else
'folder path
filedir = .SelectedItems(1) & "\"
End If
End With
'Hide Columns for BSM
Columns("A:C").EntireColumn.Hidden = True
Columns("T:AD").EntireColumn.Hidden = True
Columns("AF:AJ").EntireColumn.Hidden = True
Columns("AO:CT").EntireColumn.Hidden = True
'Start filtering
With rng
.AutoFilter Field:=34, Criteria1:=c
Filename = filedir & "\" & "c"
ActiveSheet.ExportAsFixedFormat xlTypePDF, Filename
End With
I'm having an issue with the following code, that is supposed to sequentially open 〜100 csv files, check for a value in a cell (validation, if it is file with correct structure), copy single line of data and paste it into ThisWorkbook.Worksheets("2 CSV").Range("B" & row_number).
This solution worked for two years until this month. Now the whole Excel crashes randomly on any file without any error message. Sometimes it manages to loop through 20 files, sometimes 5.
The weirdest thing is, that I can loop manually using F8 through the whole thing without any problem.
The macro:
Sub b_load_csv()
Dim appStatus As Variant
Dim folder_path As String 'folder path to where CSVs are stored
Dim file_name As String 'file name of current CSV file
Dim row_number As Integer 'row number in target sheet
Dim source_sheet_name As String 'name of the source sheet of the CSV = CSV file name
Dim wb_src As Workbook 'variable for opened CSV source workbook
Dim sht_src As Worksheet 'variable for opened CSV source sheet
Dim sht_csv As Worksheet 'variable for target sheet in ThisWorkbook
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
If .StatusBar = False Then appStatus = False Else appStatus = .StatusBar 'show currently processing file in status bar
End With
folder_path = "C:\Folder\SubFolder\" 'here are the files stored
file_name = Dir(folder_path & "*.csv") 'using dir to get file names
row_number = 3 'row number for pasting values
Set sht_csv = ThisWorkbook.Worksheets("2 CSV") 'target sheet for data aggregation
Do While file_name <> ""
Workbooks.Open (folder_path & file_name), UpdateLinks:=False, Local:=True 'open csv file
Set wb_src = Workbooks(file_name) 'assign opened csv file to variable
source_sheet_name = Left(file_name, InStr(file_name, ".") - 1) 'sheet name in csv is the same as the file name
Set sht_src = wb_src.Worksheets(source_sheet_name) 'assign source sheet to variable
If sht_src.Range("C1").Value2 = "OJ_POPIS" Then 'checks if the csv has the correct structure
sht_src.Range("A2:FZ2").Copy 'if so copies desired range
sht_csv.Range("B" & row_number).PasteSpecial 'and pastes it into target worksheet column B
End If
sht_csv.Range("A" & row_number).Value2 = file_name 'writes file name into column A
Application.CutCopyMode = False
wb_src.Close SaveChanges:=False
file_name = Dir() 'fetch next file name
row_number = row_number + 1
'the following lines is what I tried to fix the problem of random excel crashing
Set wb_src = Nothing
Set sht_src = Nothing
Application.StatusBar = "Processing file " & file_name
DoEvents
Application.Wait (Now + TimeValue("0:00:02"))
ThisWorkbook.Save 'save after every loaded file to see which files are causing the problem
Loop
MsgBox "Data from CSV files copied", vbOKOnly
Set sht_csv = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Source CSV files are encoded both in UTF-8 and ANSI (my ACP is ANSI, 1250) and ; delimited.
Group policy restricting macros doesn't apply to me. I can sign my own macros.
What I tried:
Lines of code at the end of the loop
Identifying and deleting files triggering the crash (they have nothing in common, seemingly random, by the time a remove half of them... what is the point)
Simplifying the macro
New workbook
Different machine
VPN On/Off
Thank you for your help!
First thing I'd try is include a proper error handler (not resume next), particularly with x64, and ensure 'Break on all unhandled errors' is selected in Tools / Options / General.
Second thing I'd try is avoid using the clipboard -
With sht_src.Range("A2:FZ2")
sht_cvs.Range("B" & row_number).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
(no need then to clear CutCopyMode)
Third thing I'd try is don't filter with Dir but something like this -
sFilter = "*.cvs"
file_name = Dir$(, 15) ' without vbDirectory if not getting subfolders
Do While Len(file_name)
If file_name Like sFilter Then
' process file
End If
file_name = Dir$(, 15)
Loop
Fourth thing I'd try is a good cup of coffee!
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.
I have this Macro that copies one sheet from another Workbook that i open via a File Dialog. It is supposed to sort and delete the Rows whose A Column does not possess data in an Array I've defined. It appears to be copying and pasting the data properly but when it runs through the loop to delete the data that doesn't contain the items in the array it ends up clearing the entire sheet
This Macro worked last Friday when I left for the day but now it seems it no longer works. I've tried stepping through the code but the loop doesn't appear to change much so I'm unsure why it stopped working over the weekend.
Public filepath As String
Sub SPOMacro()
'Display a Dialog Box that allows to select a single file.
'The path for the file picked will be stored in fullpath variable
With Application.FileDialog(msoFileDialogFilePicker)
'Makes sure the user can select only one file
.AllowMultiSelect = False
'Filter to just the following types of files to narrow down selection options
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
'Show the dialog box
.Show
'Store in fullpath variable
fullPath = .SelectedItems.Item(1)
End With
filepath = fullPath
'It's a good idea to still check if the file type selected is accurate.
'Quit the procedure if the user didn't select the type of file we need.
If InStr(fullPath, ".xls") = 0 Then
Exit Sub
End If
'Open the file selected by the user
'Workbooks.Open fullpath
'This is the Copy Sheet Portion
'MsgBox filepath
Dim spo_book As Workbook
Dim target_book As Workbook
Set spo_book = Workbooks("SPO_Untimed_Report.xlsm")
Set target_book = Workbooks.Open(filepath)
Dim dst_sheet As Worksheet
Dim target_sheet As Worksheet
Set dst_sheet = spo_book.Sheets("SPO Data")
Set target_sheet = target_book.Sheets("Untimed Parts")
dst_sheet.Cells.Clear
dst_sheet.Cells.Delete
Z = Cells(Sheets("Untimed Parts").Rows.Count, 1).End(xlUp).Row
target_sheet.Range("A1:R" & Z).Copy
dst_sheet.Range("A1").PasteSpecial
' Sort Pasted Data by Cost Ctr
Dim dontDelete
dontDelete = Array("RX01225", "RX01303", "RX01304", "RX01314", "RX01338", "Cost Ctr")
dst_sheet.Activate
Dim i As Long, j As Long
Dim isThere As Boolean
For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
For j = LBound(dontDelete) To UBound(dontDelete)
If StrComp(Range("A" & i), dontDelete(j), vbTextCompare) = 0 Then
isThere = True
End If
Next j
If Not isThere Then
Range("A" & i).Delete shift:=xlUp
End If
isThere = False
Next i
'Deletes Blank Rows
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
The expected outcome is that the workbook that I called SPO Untimed will keep the sheet called SPO Data and the data that is pasted into that sheet from the Selected Workbook (By the File Dialog) is sorted by the Array I've defined and only the rows that have those items in the A Column remain.
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.