Loop through Folder of Excel Workbooks and Append only Workbooks with a Key Word to Master Sheet - vba

I am looking for VBA code that would look through several hundred Workbooks and open only ones that have "cash" in the workbook title. It would then pull the second row of the first worksheet down to the last row and append it to a master worksheet.
Although I see the iteration count reaches all one hundred plus workbooks, the code appends only the first few worksheets and stops. Could anyone provide insight as to why that is happening? Thank you in advance!
Sub Pull_Cash_WB_Names()
Dim filename As Variant
Dim a As Integer
a = 1
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim LRow As Long, LCol As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Set wbDst = ThisWorkbook
strFilename = Dir("\\DATA\*Cash*")
Count = 0
Do While strFilename <> ""
Set wbSrc = Workbooks.Open("\\DATA\*Cash*")
Set wsSrc = wbSrc.Worksheets(1)
'copy all cells starting from 2nd row to last column
LRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
LCol = ActiveSheet.Cells(7, Columns.Count).End(xlToLeft).Column
Cells(2, 1).Resize(LRow - 1, LCol).Select
Selection.Copy
'paste the data into master file
wbDst.Sheets(wbDst.Worksheets.Count).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'counts the number of iterations
Count = Count + 1
Application.StatusBar = Count
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

See fixes/suggestions below
Sub Pull_Cash_WB_Names()
Const PTH As string = "\\DATA\" 'folder path goes here
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim strFilename As String
Dim rngCopy AsRange, rngDest as range
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Set wbDst = ThisWorkbook
Set rngDest = wbDst.Sheets(wbDst.Worksheets.Count).Range("A1") 'start pasting here
strFilename = Dir(PTH & "*Daily*Cash*.csv") '#EDIT#
Count = 0
Do While strFilename <> ""
Set wbSrc = Workbooks.Open(PTH & strFilename) 'full path+name
Set rngCopy = wbSrc.Worksheets(1).Range("A1").CurrentRegion 'whole table
Set rngCopy = rngCopy.Offset(1, 0).resize(rngcopy.rows.count-1) 'exclude headers
rngCopy.Copy
'paste the data into master file
rngDest.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Set rngDest = rngDest.offset(rngCopy.rows.count) 'next paste goes here...
Count = Count + 1
Application.StatusBar = Count
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Related

Copy and paste a fixed column to a master sheet next to each other

I am trying to copy a fixed column from files in a folder, I am extracting column N only and pasting them onto an active sheet with columns right next to each other. However, I am getting error message, please help me
Sub LoopThroughDirectory()
Dim MyFile As String
Dim Filepath As String
Dim Wb As Workbook, _
Ws As Worksheet, _
PasteRow As Long
Filepath = "\\123.20.0.89\Risk_dept\"
Set Ws = ActiveSheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
PasteCloumn = Ws.Range("A" & Ws.Columns.Count).End(xlToRight).Column + 1
Set Wb = Workbooks.Open(Filepath & MyFile)
Worksheets("part 5").Range("N2:N200").Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range("A:A").End(xlToRight).Column + 1
Applicaiotn.CutCopyMode = False
MyFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This works for me. Extracts column N from files in folder and pastes them into active sheet.
Sub LoopThroughDirectory()
Dim filePath As String, target As Worksheet, file As String, wb As Workbook, col As Long
filePath = "\\123.20.0.89\Risk_dept\"
Set target = ActiveSheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
file = Dir(filePath)
Do While Len(file) > 0
If file = "zmaster.xlsm" Then
Exit Sub
End If
Set wb = Workbooks.Open(filePath & file)
col = target.Range("A1").End(xlToRight).Column + 1
wb.Worksheets("part 5").Range("N2:N200").Copy Destination:=target.Cells(1, col)
file = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Vlookup on external workbook VBA

I don't know how it isn't working.
I have my active workbook. I want to run macros from active sheet.
1. I want to add 2 more columnes with headers . - works
2. I want to open external file, which is base in my vloop. - works
3. I want to use vloop to find my variable from active sheet in external workbook and save result in my active sheet
Sub ImpFPQ()
Application.ScreenUpdating = False
On Error Resume Next
Dim Imp_Row As Integer
Dim Imp_Col As Integer
Dim Baza1 As Workbook
Dim Baza2 As Workbook
Dim wksheet As Worksheet
Dim plik As Variant
Set wksheet = ActiveWorkbook.ActiveSheet
'add columns with names
wksheet.Columns("A:B").Insert Shift:=xlToRight
wksheet.Columns("A").Cells(1, 1) = "KOD"
wksheet.Columns("B").Cells(1, 1) = "LICZNIK"
'open file
plik = Application.GetOpenFilename(Title:="Wybierz raport")
If plik = False Then Exit Sub
Workbooks.Open Filename:=plik
Set Baza1 = ThisWorkbook 'activesheet
Set Baza2 = Workbooks(plik) 'external workbook
Set lastel = Baza2.Range("F3", Range("F3").End(xlDown)).Select
Set lookFor = Baza1.Cells(2, 4) 'aktualny subsyst do znalezienia
Set srchRange = Baza2.Sheets(1).Range("A3:lastel")
Range("A2").Value = Application.VLookup(lookFor, srchRange, 6, False)
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
I have these columns, but rows dont have results. Can someone help me?
This should do the trick.
Sub ImpFPQ()
Application.ScreenUpdating = False
On Error Resume Next
Dim Imp_Row As Integer
Dim Imp_Col As Integer
Dim Baza1 As Workbook
Dim Baza2 As Workbook
Dim wksheet As Worksheet
Dim plik As Variant
Dim lastRow As Long
Dim lookfor As Variant
Dim srchRange As Range
Set wksheet = ActiveWorkbook.ActiveSheet
'add columns with names
wksheet.Columns("A:B").Insert Shift:=xlToRight
wksheet.Columns("A").Cells(1, 1) = "KOD"
wksheet.Columns("B").Cells(1, 1) = "LICZNIK"
'open file
plik = Application.GetOpenFilename(Title:="Wybierz raport")
If plik = False Then Exit Sub
Workbooks.Open Filename:=plik
Set Baza1 = ThisWorkbook 'activesheet
Set Baza2 = Workbooks.Open(plik) 'external workbook
With Baza2.Sheets(1)
lastRow = .Cells(.Rows.Count, 6).End(xlUp).Row
End With
lookfor = Baza1.Cells(2, 4) 'aktualny subsyst do znalezienia
Set srchRange = Baza2.Sheets(1).Range("A3:F" & lastRow)
Range("A2").Value = Application.VLookup(lookfor, srchRange, 6, False)
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Change this:
If plik = False Then Exit Sub
Workbooks.Open Filename:=plik
Set Baza1 = ThisWorkbook 'activesheet
Set Baza2 = Workbooks(plik) 'external workbook
To this:
If plik = False Then Exit Sub
Set Baza2 = Workbooks.Open(Filename:=plik)
Set Baza1 = ThisWorkbook 'activesheet
since plik is giving you a full filename (including a path) I don't think it can be used as an index for the Workbooks collection
See here: https://msdn.microsoft.com/en-us/vba/excel-vba/articles/workbook-object-excel

Merge Many excel files to one new file with different sheet

I am trying to merge many excel files (workbooks) from a folder.
My problem is that I want to move different sheets to the new excel file.
At the moment my code can only move one sheet at the time from these different files.
Example:
I have 3 excel files named
1.xlsx
2.xlsx
3.xlsx
all 3 files have 3 sheets in it and I want to take sheet1 from 1.xlsx and sheet1 and sheet2 from 2.xlsx and finally sheet3 from 3.xlsx and put in a new excel file.
My code at the moment can only takes one sheet (and same sheet number) from each file and put in the new file.
My code so fare:
Sub MergeMultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim Path As String
Dim Filename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
path = "C:\Users\*ChangeThis*\Desktop\merge"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
Filename = Dir(path & "\*.xlsx", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = ""
Set wbSrc = Workbooks.Open(Filename:=path & "\" & Filename)
sheet = 1
Set wsSrc = wbSrc.Worksheets(sheet)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
Filename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Many thank in advance
You need to loop through all the Sheets in the current Workbook found in your folder.
Try the code below:
Sub MergeMultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim Path As String
Dim Filename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\Users\*ChangeThis*\Desktop\merge"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
Filename = Dir(Path & "\*.xlsx", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = ""
Set wbSrc = Workbooks.Open(Filename:=Path & "\" & Filename)
Sheet = 1
' ****** you need to loop on all sheets per Excel workbook found in Folder ******
For Each wsSrc In wbSrc.Sheets
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
Next wsSrc
wbSrc.Close False
Filename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

VBA to import and transpose multiple sheets data

I have been working on the below code, however I am looking to edit this further:
1) Instead of setting 'Set Range1' via an input box, this should always be the cell range of 'B2:P65' when looping through the sheets in the folder.
2) When pasting the data I want this to fill starting at column B of the 'Database' tab in the workbook and then subsequently C, D, E etc.. for the rest of the workbooks in the folder loop.
Sub LoopFileUpload_base()
Dim wb As Workbook
Dim myPath As String
Dim myfile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
myExtension = "*.xlsx"
myfile = Dir(myPath & myExtension)
Do While myfile <> ""
Set wb = Workbooks.Open(fileName:=myPath & myfile)
'CHANGE CODE BELOW HERE
xTitleId = "Range"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
For Each Rng In Range1.Rows
Rng.Copy
Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
rowIndex = rowIndex + Rng.Columns.Count
Next
'CHANGE CODE ABOVE HERE
wb.Close SaveChanges:=True
myfile = Dir
Loop
MsgBox "Task Complete!"
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Consider the following macro where you loop through .xlsx workbooks in a folder and iteratively copy cells in specified range to current sheet row by row. Then, after each workbook move to next column:
Sub TransposeWorkbooks()
Dim strfile As String
Dim sourcewb As Workbook
Dim i As Integer, j As Integer
Dim cell As Range
strfile = Dir("C:\Path\To\Workbooks\*.xlsx")
ThisWorkbook.Sheets("Database").Activate
ThisWorkbook.Sheets("Database").Range("A2").Activate
Do While Len(strfile) > 0
' OPEN SOURCE WORKBOOK
Set sourcewb = Workbooks.Open("C:\Path\To\Workbooks\" & strfile)
ThisWorkbook.Activate
ActiveCell.Offset(0, 1).Activate ' MOVE TO NEXT COLUMN
ActiveCell = strfile
' ITERATE THROUGH EACH CELL ACROSS RANGE
j = 1
For Each cell In sourcewb.Sheets(1).Range("B2:P65")
ActiveCell.Offset(j, 0).Value = cell.Value ' MOVE TO NEXT ROW
j = j + 1
Next cell
' CLOSE WORKBOOK
sourcewb.Close False
strfile = Dir
Loop
End Sub
It sounds like you got your task solved. For future reference, please try the AddIn from the link below. I think you will find so many uses for this tool.
http://www.rondebruin.nl/win/addins/rdbmerge.htm

Creating a loop to copy a result row from number of worksheets to a new worksheet

Good afternoon,
I am trying to read number of csv files and load them in a new workbook. Then created codes to find the largest number from each column (i.e. maximum value) and pasted in the bottom of each column. I have completed up to the stage of calcualting the largest value and pasting in the lastrow with the help of this forum.
Now I am trying to transfer them in a new worksheet that I created and named as result with my code. With previous suggestions I have figured out how to paste a specific range from one column to another worksheet with the following example:
Sub OneCell()
Sheets("Result").Range("E3:V3").Value = Sheets("HP5_1gs_120_2012.plt").Range("E3:V3").Value
End Sub
But not sure how can I loop this with my existing codes to read the last row where my max values are (highlighted in yellow in figure 1) and paste to the result sheet with the header from column E to the last available column and the rowname as the worksheet name. My data structure will be same for each worksheet for each run. And my start column is always column "E" but the end column (i.e. the last column) can be different for each run. THis is what I am getting really confused of how do I loop thorugh this. So for an example a simple dataset like below (Figure 1):
I am trying to achieve this (figure 2):
my main codes are as below:
Private Sub FilePath_Button_Click()
get_folder
End Sub
Private Sub Run_Button_Click()
load_file
End Sub
Public Sub get_folder()
Dim FolderName As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
TextBox1.Text = FolderName
End Sub
Sub load_file()
Dim strFile As String
Dim ws As Worksheet
Dim test As String
Dim wb As Workbook
test = TextBox1.Text
strFile = Dir(Me.TextBox1.Text & "\*.csv")
Set wb = Workbooks.Add
'added workbook becomes the activeworkbook
With wb
Do While Len(strFile) > 0
Set ws = ActiveWorkbook.Sheets.Add
ws.Name = strFile
With ws.QueryTables.Add(Connection:= _
"TEXT;" & test & "\" & strFile, Destination:=Range("$A$1"))
.Name = strFile
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
strFile = Dir
Loop
End With
Application.DisplayAlerts = False
Worksheets("Sheet1").Delete
Worksheets("Sheet2").Delete
Worksheets("Sheet3").Delete
Application.DisplayAlerts = True
Dim ws1 As Worksheet
Dim ColNo As Long, lc As Long
Dim lastrow As Long
For Each ws1 In ActiveWorkbook.Worksheets
lastrow = Range("A1").End(xlDown).Row
lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
For ColNo = 5 To lc
ws1.Cells(lastrow + 2, ColNo).Formula = "=MAX(" & Split(Cells(, ColNo).Address, "$")(1) & "1:" & Split(Cells(, ColNo).Address, "$")(1) & lastrow & ")"
Next ColNo
Next ws1
Dim ws2 As Worksheet
Set ws2 = Sheets.Add
Sheets.Add.Name = "Result"
MsgBox "Job Complete"
End Sub
Private Sub UserForm_Click()
End Sub
I hope I have managed to explain what I am trying to acheive and I would really appreciate any guidence with this. Thanks
Something like the below should do it. No doubt you will want to tweak bits but the general structure is there. I have commented what each block is doing - make sure you understand each line.
But normally for asking questions you should really really break the question down into its parts.
Like - "How do I loop through sheets", then "How do I find the last row of a sheet", then "How do I copy ranges" etc.
You would find that every single one of those has been asked before so in fact a little searching of Stackoverflow would be all that is needed.
Sub example()
Dim ws As Worksheet, dWs As Worksheet 'variables for ws enumerator and destination ws
Dim wb As Workbook 'variable to define the workbook context
Dim sRng As Range, dRng As Range 'variables for source range and destination range
Set wb = ActiveWorkbook
'Add the results sheet and assign our current row range
Set dWs = wb.Worksheets.Add
Set dRng = dWs.Cells(2, 1)
'Change the results sheet name (error if name exists so trap it)
On Error Resume Next
dWs.Name = "Result"
On Error GoTo 0
'Loop worksheets
For Each ws In wb.Worksheets
'Only work on the .csv sheet names
If ws.Name Like "*.csv" Then
'Find the row with the values on
Set sRng = ws.Cells(ws.Rows.Count, 4).End(xlUp)
'And set the range to be to the contiguous cells to the right
Set sRng = ws.Range(sRng, sRng.End(xlToRight))
'Add the sheet name to the results col A
dRng.Value = ws.Name
'Copy sRng to the output range
sRng.Copy dRng(1, 2)
'Increment output row to the next one
Set dRng = dRng(2, 1)
End If
Next ws
'Now just add the headers
For Each dRng In dWs.Range(dWs.Cells(1, 2), dWs.Cells(1, dWs.Cells.Find("*", , XlFindLookIn.xlFormulas, , XlSearchOrder.xlByColumns, xlPrevious).Column))
dRng.Value = "data " & dRng.Column - 1
Next
End Sub