I have some csv files in one folder. They all contain 3 specific columns. The number of total columns and the order may vary.
I want to concatenate all 3 columns with an underscore and write them in a single column in the worksheet that is running the code.
Here is what I have so far:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
Cells(i, 1) = Cells(i, Columns(0)) & "_" & Cells(i, Columns(1)) & "_" & Cells(i, Columns(2))
Next i
End Sub
As you can see, this does what I want, but only for the active sheet.
I actually want to loop through all csv files in the same folder as the active sheet and write the results in the first sheet, first column of the sheet running the code (which is not a csv itself obviously).
How can I do this?
thanks!
This is a code that will loop through a folder
Sub Button1_Click()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\WorkBookLoop\"
MyFile = Dir(MyDir & "*.xls") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
'do something here
MyFile = Dir()
Loop
End Sub
It depends how you are naming the worksheets you create from the CSV files. You could add all the worksheets to a collection and use a For...Each loop to execute the entire search and concatenate procedure within that loop. Note that you'd have to explicitly define the first sheet name as this won't change through successive loops:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Dim frontSheet as Worksheet
Dim wSheets as New Collection
Dim ws as Worksheet
Set frontSheet = Sheets("name of front sheet")
'Add all your CSV sheets to wSheets using the .Add() method.
For Each ws in wSheets
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = ws.Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
frontsheet.Cells(i, 1) = ws.Cells(i, Columns(0)) & "_" & ws.Cells(i, Columns(1)) & "_" & ws.Cells(i, Columns(2))
Next i
Next ws
End Sub
It's often slow and labourious to open CSV files in excel but VBA can read them as text files using a TextStream. Furthermore, file scripting objects let you work with files and directories directly. Something like this might be a better approach if you don't need to keep the files in a worksheet afterwards:
Sub SearchFoldersForCSV()
Dim fso As Object
Dim fld As Object
Dim file As Object
Dim ts As Object
Dim strPath As String
Dim lineNumber As Integer
Dim lineArray() As String
Dim cols() As Integer
Dim i As Integer
Dim frontSheet As Worksheet
Dim frontSheetRow As Integer
Dim concatString As String
Set frontSheet = Sheets("name of front sheet")
frontSheetRow = 1
strPath = "C:\where-im-searching\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
For Each file In fld.Files
If (Right(file.Name, 3) = "csv") Then
Debug.Print file.Name
Set ts = file.OpenAsTextStream()
lineNumber = 0
Do While Not ts.AtEndOfStream
lineNumber = lineNumber + 1
lineArray = Split(ts.ReadLine, ",")
If (lineNumber = 1) Then
'We are at the first line of the .CSV so
'find index in lineArray of columns of interest
'Add extra ElseIf as required
For i = LBound(lineArray) To UBound(lineArray)
If lineArray(i) = "Column 1" Then
cols(1) = i
ElseIf lineArray(i) = "Column 2" Then
cols(2) = i
ElseIf lineArray(i) = "Column 3" Then
cols(3) = i
End If
Next i
Else
'Read and store the column of interest from this
'row by reading the lineArray indices found above.
concatString = ""
For i = LBound(cols) To UBound(cols)
concatString = concatString & lineArray(i) & "_"
Next i
concatString = Left(concatString, Len(concatString) - 1)
frontSheet.Cells(frontSheetRow, 1).Value = concatString
frontSheetRow = frontSheetRow + 1
End If
Loop
ts.Close
End If
Next file
End Sub
You can find more information on FileSystemObject and TextStream here.
Related
I need to create code that does the following:
Searches a destination folder that contains hundreds of excel sheets
Looks for the string "Current Risk" (the cell containing the string Current Risk is merged¢ered - does this count as Column 1?)
Once the keyword is found, copies and pastes data in different columns under the equipment ID that is:
3a) (2,2) from the keyword [this will return the ID from attached picture below]
3b) (5,3) from the keyword [this will return the corrosion rate from the picture]
3c) (5,4) from the keyword [ this will return the remaining half-life from the picture]
There will be other boxes lower down with the same Current Risk target word but with different equipment IDs.
We need to collect all this data again for the next equipment ID for each encounter of the word Current Risk. So loop down the sheet collecting all the current risk data with each encounter and then onto the next workbook in the folder and repeat.
Paste all this data into a new master Workbook.
Code for a previous project that might give a head start. This code looked for keywords at the top of a column and pasted the whole column's data into a new master workbook head-to-tail one after another.
Sub Merges()
Dim strFileName As String
Dim strFilesLike As String
Dim strPathName As String
Dim strCurrentFile As String
pth = "C:\Users\phil\Desktop\Reports\MASTER\"
Set tgt = Workbooks.Open(pth & "master file.xlsx")
strPathName = "C:\Users\phil\Reports\MASTER\Data\"
strFilesLike = "*.xls*"
strFileName = strPathName & strFilesLike
strCurrentFile = Dir(strFileName)
Do While strCurrentFile <> ""
' Combine file data code goes here
Set src = Workbooks.Open(strPathName & strCurrentFile)
Set dest = tgt.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
Set src = ActiveWorkbook
With src.Sheets("Hierarchy Item Attributes")
Set colh = .Range("1:1").Find("Hierarchy Item Site")
cnt = Cells(Rows.Count, colh.Column).End(xlUp).Row - 1
dest.Resize(cnt).Value = colh.Offset(1).Resize(cnt).Value
Set colh = .Range("1:1").Find("Hierarchy Item Address")
dest.Offset(, 1).Resize(cnt).Value = colh.Offset(1).Resize(cnt).Value
On Error Resume Next
Set colh = .Range("1:1").Find("Hierarchy Item Address")
dest.Offset(, 2).Resize(cnt).Value = colh.Offset(1).Resize(cnt).Value
Set colh = .Range("1:1").Find("Hierarchy Item Name")
dest.Offset(, 3).Resize(cnt).Value = colh.Offset(1).Resize(cnt).Value
End With
src.Close False
' Get next file to Import
strCurrentFile = Dir
Loop
End Sub
Picture of one of the xlsm sheets to search
This creates a new Master workbook. Use FindNext to continue the search.
Option Explicit
Sub Merges()
Const PTH = "C:\Users\phil\Desktop\Reports\MASTER\"
Const TERM = "Current Risk"
Dim wbMaster As Workbook, wb As Workbook
Dim ws As Worksheet, wsMaster As Worksheet
Dim strFileName As String, strFilesLike As String
Dim strPathName As String, strCurrentFile As String
Dim strMaster As String
Dim r As Long, n As Long
Dim rng As Range, first As String
Set wbMaster = Workbooks.Add(1)
Set wsMaster = wbMaster.Sheets(1)
With wsMaster
.Name = "Master"
.Range("A1:D1") = Array("ID", "Corrosion Rate", "Half Life", "Sheet")
End With
r = 2
strPathName = PTH & "Data1\"
strFilesLike = "*.xls*"
strFileName = strPathName & strFilesLike
strCurrentFile = Dir(strFileName)
Application.ScreenUpdating = False
Do While strCurrentFile <> ""
Set wb = Workbooks.Open(strPathName & strCurrentFile, True, True)
For Each ws In wb.Sheets
With ws.UsedRange
Set rng = .Find(TERM, lookat:=xlWhole, LookIn:=xlValues, after:=.Cells(.Cells.Count))
If Not rng Is Nothing Then
first = rng.Address
Do
wsMaster.Cells(r, 1) = ws.Cells(rng.Row + 1, "B") 'ID
wsMaster.Cells(r, 2) = ws.Cells(rng.Row + 8, "E") 'Corrision Rate
wsMaster.Cells(r, 3) = ws.Cells(rng.Row + 8, "F") 'Half Life
wsMaster.Cells(r, 4) = wb.Name & " " & ws.Name & " row " & rng.Row
r = r + 1
Set rng = .FindNext(rng)
Loop While rng.Address <> first
End If
End With
Next
wb.Close False
' Get next file to Import
strCurrentFile = Dir
n = n + 1
Loop
Application.ScreenUpdating = True
' save
strMaster = PTH & "master_" & Format(Now(), "yyyy-mm-dd_hhmmss")
wbMaster.SaveAs strMaster
'wbMaster.Close
MsgBox n & " files scanned into " & strMaster, vbInformation
End Sub
I'm trying to code a Macro in Excel that:
Goes through hundreds of .csv files.
Get their names and put them in the first row of the target workbook.
Copy columns E & R from each .csv file and paste them below their corresponding name in the target workbook.
Example: in the target workbook, I should get, the title_1 (of csv_1) in cell A1, then data from columns E & R of csv_1 pasted in cells A2 & B2. Column C empty. Then title_2 (of csv_2) in cell D1, respective columns E & R pasted in D2 & E2. Column F empty and so on...
I would like the data to be organize like this
Attempt:
Sub LoopExcels ()
Dim directory As String
Dim fileName As String
Dim i As Integer
Dim j As Integer
Dim wb As Workbook
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim ColOutputTarget As Long
ColOutputTarget = 1
Set wsTarget = Sheets("Sheet1")
Application.ScreenUpdating = FALSE
Application.DisplayAlerts = FALSE
directory = "C:\data"
fileName = Dir(directory & "*.csv")
Do Until fileName = ""
Set wbSource = Workbooks.Open(directory & fileName)
Set wsSource = wbSource.Worksheets(1)
j = j + 1
i = 1
Cells(i, 1) = fileName
Workbooks.Open (directory & fileName)
For Each sheet In Workbooks(fileName).Worksheets 'my excels contain only one sheet but didn't know how to get rid of the "For each sheet"
wsTarget.Cells(i, j).Value = sheet.Name
j = j + 2
Next sheet
With wsTarget
.Range("A" & ColOutputTarget).Value = wsSource.Range("E1:E100").Value 'Need to copy all data in columns it can be 10 cells and it doesn't exceed 100 cells
.Range("B" & ColOutputTarget).Value = wsSource.Range("R1:R100").Value
ColOutputTarget = ColOutputTarget + 1
End With
wbSource.Close SaveChanges:=False
fileName = Dir()
Loop
Application.CutCopyMode = FALSE
End Sub
I've been looking for a solution with no luck.
I found a way to loop through files
I managed partially to get the names of each file (I found a code that goes thru all sheets in an Excel file. My files contain only one sheet so maybe it can be simplified)
And for some reason it doesn't copy the full name. some files have LONG names +50 characters.
I am having issues with copy/pasting the columns. Each column has data from 10 to 100 cells.
The code below, go thru the files but paste the data in the same column. I end up getting only the data from the last excel file it opens which get pasted in the first 2 columns.
I can't find a way to make it shift to the next column every time its done with each csv file.
For order to work:
you need to place the Excel file (that has the macro) inside the folder of the .CSV files.
create 2 sheets in the main Excel file with the names "file names" and "target sheet". You can change this in the code if you want.
if you are using Windows just insert the path of the folder containing the .csv files.
if you are using mac insert the path of the folder containing the .csv files and change all the "\" in the macro to "/".
Sub Awesome()
getNames
positionTitles
transferData
End Sub
Sub getNames()
Dim sFilePath As String
Dim sFileName As String
Dim counter As Long
counter = 1
'Specify folder Path for the .csv files
sFilePath = "c:\"
'Check for back slash
If Right(sFilePath, 1) <> "\" Then
sFilePath = sFilePath & "\"
End If
sFileName = Dir(sFilePath & "*.csv")
Do While Len(sFileName) > 0
If Right(sFileName, 3) = "csv" Then
'Display file name in immediate window
Sheets("file names").Cells(counter, 1) = sFileName
counter = counter + 1
End If
'Set the fileName to the next available file
sFileName = Dir
Loop
End Sub
Sub positionTitles()
Dim counter As Long
Dim used_range As Range
Dim col As Long
col = 1
Set used_range = Sheets("file names").UsedRange
For counter = 1 To used_range.Rows.Count
Sheets("target sheet").Cells(1, col) = Sheets("file names").Cells(counter, 1)
col = col + 4
Next counter
End Sub
Sub transferData()
'turn off unnecessary applications
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim file_name As String
Dim counter As Long
Dim used_range As Range
Dim main_wb As Workbook
Dim col As Long
Dim key As Boolean
Dim last_row As Long
Dim second_key As Boolean
col = 1
Set main_wb = ThisWorkbook
Set used_range = Sheets("file names").UsedRange
For counter = 1 To used_range.Rows.Count
file_name = main_wb.Sheets("file names").Cells(counter, 1)
Workbooks.Open ActiveWorkbook.Path & "\" & file_name, Local:=True
'transfer data to target_sheet
For col = col To 1000
If key = False Then
last_row = ActiveWorkbook.ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row
ActiveWorkbook.ActiveSheet.Range("E1:E" & last_row).Copy
main_wb.Sheets("target sheet").Cells(2, col).PasteSpecial
key = True
ElseIf second_key = False Then
last_row = ActiveWorkbook.ActiveSheet.Range("R" & Rows.Count).End(xlUp).Row
ActiveWorkbook.ActiveSheet.Range("R1:R" & last_row).Copy
main_wb.Sheets("target sheet").Cells(2, col).PasteSpecial
second_key = True
Else
last_row = ActiveWorkbook.ActiveSheet.Range("K" & Rows.Count).End(xlUp).Row
ActiveWorkbook.ActiveSheet.Range("K1:K" & last_row).Copy
main_wb.Sheets("target sheet").Cells(2, col).PasteSpecial
col = col + 2
Exit For
End If
Next col
key = False
second_key = False
Workbooks(file_name).Close savechanges:=False
Next counter
'turn on applications
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.DisplayAlerts = True
End Sub
I currently have VBA code that opens each text file in a given location and imports data into Excel. The problem is that I have 1000's of text file in the location and I do not want to import them all. I only want to import the 10 most recently created text files. How do I change my Do While loop to achive this?
Sub LoopThroughTextFiles()
' Defines variables
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim Text As String
Dim Textline As String
Dim LastCol As Long
Dim RowCount As Long
' Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("26").Select
Cells.Select
Selection.ClearContents
Range("A1").Select
' Defines LastCol as the last column of data based on row 1
LastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
' Sets the folder containing the text files
myPath = "C:\26" & "\"
' Target File Extension (must include wildcard "*")
myExtension = "*.dat"
' Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
' Loop through each text file in folder
Do While myFile <> ""
' Sets variable "RowCount" To 1
RowCount = 1
' Sets variable "Text" as blank
Text = ""
' Set variable equal to opened text file
Open myPath & myFile For Input As #1
' Do until the last line of the text file
Do Until EOF(1)
' Add each line of the text file to variable "Text"
Line Input #1, Textline
Text = Textline
' Update RowCount row of the current last column with the content of variable "Text"
Cells(RowCount, LastCol).Value = Text
' Increase RowCount by 1
RowCount = RowCount + 1
Loop
' Close the text file
Close #1
' Increase LastCol by 1 to account for the new data
LastCol = LastCol + 1
' Get next text file name
myFile = Dir
Loop
Please try this approach. There are two constants at the top of the code which you may need to adjust. TopCount represents the number of files you want the names of. In your question this is 10 but in the code you can enter any number. TmpTab is the name of a worksheet the code will create in the ActiveWorkbook. Please pay close attention to this word: The ActiveWorkbook is the workbook you last looked at before you ran the code. It need not be the workbook that contains the code. Anyway, the code will create a worksheet by the name prescribed by the constant `TmpTab', use it for sorting and then delete it. If this is a name of an existing worksheet it will be cleared, used and deleted.
Function TenLatest() As String()
Const TopCount As Long = 10 ' change to meet requirement
Const TmpTab As String = "Sorter"
Dim Fun() As String ' function return value
Dim SourceFolder As String
Dim Fn As String ' File name
Dim Arr() As Variant
Dim Ws As Worksheet
Dim Rng As Range
Dim i As Long
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then ' if OK is pressed
SourceFolder = .SelectedItems(1)
End If
End With
If SourceFolder <> "" Then ' a folder was chosen
ReDim Arr(1 To 2, 1 To 10000) ' increase if necessary
Fn = Dir(SourceFolder & "\*.TXT") ' change the filter "TXT" if necessary
Do While Len(Fn) > 0
i = i + 1
Arr(1, i) = SourceFolder & "\" & Fn
Arr(2, i) = FileDateTime(Arr(1, i))
Fn = Dir
Loop
If i < 1 Then i = 1
ReDim Preserve Arr(1 To 2, 1 To i)
Application.ScreenUpdating = False
On Error Resume Next
Set Ws = Worksheets(TmpTab)
If Err Then
Set Ws = Worksheets.Add
Ws.Name = TmpTab
End If
With Ws
.Cells.ClearContents
Set Rng = .Cells(1, 1).Resize(UBound(Arr, 2), UBound(Arr, 1))
Rng.Value = Application.Transpose(Arr)
With .Sort.SortFields
.Clear
.Add Key:=Rng.Columns(2), _
SortOn:=xlSortOnValues, _
Order:=xlDescending, _
DataOption:=xlSortNormal
End With
With .Sort
.SetRange Rng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
With Rng.Columns(1)
i = Application.WorksheetFunction.Min(.Rows.Count, TopCount)
Arr = .Range(.Cells(1), .Cells(i)).Value
End With
ReDim Fun(1 To UBound(Arr))
For i = 1 To UBound(Fun)
Fun(i) = Arr(i, 1)
Next i
TenLatest = Fun
With Application
.DisplayAlerts = False
Ws.Delete
.ScreenUpdating = True
.DisplayAlerts = True
End With
End If
End Function
The above code returns an array of (10) file names which you can use in whichever way is suitable for you. To test the function please use the procedure below. It will call the function and write its result to the Immediate Window.
Private Sub TestTenLatest()
Dim Fun() As String
Dim i As Integer
Fun = TenLatest
For i = 1 To UBound(Fun)
Debug.Print i, Fun(i)
Next i
End Sub
The solution that worked for me in the end was as follow. Specifically the line "test = FileDateTime(myPath & myFile)" did the trick for me. I then wrote the result back into the top row of the column the data was being pulled into.
Sub LoopThroughTextFiles()
' Defines variables
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim Text As String
Dim Textline As String
Dim LastCol As Long
Dim RowCount As Long
Dim test As Date
Dim fso As Object
' Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("Sheet1").Select
Cells.Select
Selection.ClearContents
Range("A1").Select
' Defines LastCol as the last column of data based on row 1
LastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
' Sets the folder containing the text files
myPath = "\\YourLocation" & "\"
' Target File Extension (must include wildcard "*")
myExtension = "*.dat"
' Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
' Loop through each text file in folder
Do While myFile <> ""
' Sets variable "RowCount" To 1
RowCount = 1
' Sets variable "Text" as blank
Text = ""
' Set variable equal to opened text file
Open myPath & myFile For Input As #1
' Do until the last line of the text file
Do Until EOF(1)
' Add each line of the text file to variable "Text"
Line Input #1, Textline
Text = Textline
' Update RowCount row of the current last column with the content of variable "Text"
Cells(RowCount, LastCol).Value = Text
' Increase RowCount by 1
RowCount = RowCount + 1
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
test = FileDateTime(myPath & myFile)
Cells([1], LastCol).Value = test
' Close the text file
Close #1
' Increase LastCol by 1 to account for the new data
LastCol = LastCol + 1
' Get next text file name
myFile = Dir
Loop
I have search and search for an answer to my code issue but I cant find any. I will be very grateful if someone can take a look at my code. At the moment, I have several large workbooks for data for each country. Each workbook has more that 5 work sheets. I want to consolidate the workbooks into a master file. First, I wan to copy and paste all worksheets under one work sheet in the master workbook and name it all by the country. Right now, my code is only able to consolidate one country at a time which makes it very slow. also the loop worksheet seems to the failing. It creates only one country worksheet. If I put in multiple country names, only the last country workbook gets consolidated. Something is missing but I cant seem to figure it out. Thank you so much!!!! Below is my code:
Sub consolidate()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim countryname As String
Dim LastRow, Rowlast, Rowlast2 As Long
Const fr As Long = 2
Dim i As Long
Dim cell As Range
Dim wx As Worksheet
Set wx = ThisWorkbook.Sheets("Countryname")
Rowlast = wx.Range("B" & Rows.Count).End(xlDown).row 'selects list of country workbook I want to consolidate. e.g I could have Germany, usa, china
Rowlast2 = wx.Range("C" & Rows.Count).End(xlDown).row 'selects list of tabs for each country workbook I want to consolidate, e.g I want for every country listed above, that sheet names 1, 2, 3, 4 be consolidated and put in new worksheets in the masterfile
With wx
For LastRow = fr To Rowlast
If .Cells(LastRow, "B").Value <> "" Then
countryname = .Cells(LastRow, "B").Value
' set master workbook
Set Masterwb = Workbooks("ebele_test.xlsm")
folderPath = Application.InputBox(Prompt:= _
"Please enter only folder path in this format as C:\Users\... Exclude the file name", _
Title:="InputBox Method", Type:=2) 'Type:=2 = text
If folderPath = "False" Or IsError(folderPath) Then 'If Cancel is clicked on Input Box exit sub
MsgBox "Incorrect Input, Please paste correct folder path"
Exit Sub
'On Error GoTo 0
End If
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
Application.ScreenUpdating = False
Dim str As String
str = "Screener_User_Template-"
Filename = Dir(folderPath & str & countryname & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(folderPath & Filename)
If Len(wb.Name) > 253 Then
MsgBox "Sheet's name can be up to 253 characters long, shorten the Excel file name"
wb.Close False
GoTo Exit_Loop
Else
' add a new sheet with the file's name (remove the extension)
With Masterwb
Dim isLastSheet As Boolean
Dim ci, rows1 As Integer
Dim row As Long
rows1 = ThisWorkbook.Worksheets.Count
For ci = rows1 To 1 Step (-1)
If (isLastSheet) = False Then
Set NewSht = Masterwb.Worksheets.Add(After:=Worksheets(ci)) 'Place sheet at the end.
NewSht.Cells(1, 1) = "Identifier"
NewSht.Cells(1, 2) = "Company Name"
NewSht.Cells(1, 3) = "Country of Incorporation"
NewSht.Name = countryname
End If
Next ci
End With
End If
' loop through all sheets in opened wb
For Each sh In wb.Worksheets
For i = 2 To Rowlast2
If sh.Name = wx.Cells(i, "C").Value And NewSht.Name = countryname Then
' get the first empty row in the new sheet
Set FindRng = NewSht.Cells.Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not FindRng Is Nothing Then ' If find is successful
PasteRow = FindRng.row + 1
Else ' find was unsuccessfull > new empty sheet, should paste at the second row
PasteRow = 2
End If
Dim rng As Range
Set rng = sh.Range(sh.Cells(3, "A"), sh.Cells(150000, "M"))
rng.Copy
NewSht.Range("A" & PasteRow).PasteSpecial xlPasteValues
End If
Application.CutCopyMode = False 'Clears the clipboard
Next i
Next sh
wb.Close False
Exit_Loop:
Set wb = Nothing
Filename = Dir
Loop
End If
Next LastRow
End With
'0: Exit Sub
Application.ScreenUpdating = True
End Sub
It's a Mess
This is not a solution, just a work in progress which I cannot continue due to lack of information and knowledge. It could help you to finish what you started. It would be a shame to quit after you have invested so much time in it. If you provide some answers from the questions in the code someone else might help you finish it. The questions are by no means ironic, they're serious questions that I cannot answer for sure.
The code should be safe, but just don't save anything not to lose data.
I would suggest you somehow split such a code into several and ask several questions to get answers in the future.
Option Explicit
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
' ThisWorkbook
Const cStrCountry As String = "CountryName"
Const cLngRow1 As Long = 2
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntColCountries As Variant = "B"
Const cVntColTabs As Variant = "C"
Const cStrTemplate = "Screener_User_Template-"
Const cStrMaster As String = "ebele_test.xlsm"
Const cStrExt = ".xlsx"
' New Worksheet in Master Workbook
Const cStrNewHeader1 = "Identifier"
Const cStrNewHeader2 = "Company Name"
Const cStrNewHeader3 = "Country of Incorporation"
' Each Worksheet in Each Workbook
Const cLngFirstRow As Long = 3
Const cLngLastRow As Long = 150000
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntFirstCol As Variant = "A"
Const cVntLastCol As Variant = "M"
' MsgBox
Dim strMsg1 As String
strMsg1 = "Please enter only folder path in this format as " _
& "C:\Users\... Exclude the file name"
Dim strMsg2 As String
strMsg2 = "Incorrect Input. Please paste correct folder path."
Dim strMsg3 As String
strMsg3 = "Sheet's name can only be up to 253 characters long. " _
& "Shorten the Excel file name."
' Workbooks
' ThisWorkbook
Dim ojbWbEach As Workbook ' Workbook Looper
Dim objWbMaster As Workbook ' Master Workbook
' Worksheets
' ThisWorkbook.Worksheets (cStrCountry)
Dim objWsEach As Worksheet ' Worksheet Looper
Dim objWsNew As Worksheet ' New Worksheet
' Arrays Pasted From Ranges
Dim vntCountries As Variant ' List of Countries
Dim vntTabs As Variant ' List of Tabs
' Ranges
Dim objRngEmpty As Range ' New Sheet Paste Cell
' Rows
Dim lngPasteRow As Long ' New Sheet Paste Row
Dim lngCountries As Long ' Countries Counter
Dim lngTabs As Long ' Tabs Counter
' Strings
Dim strPath As String
Dim strFile As String
Dim strCountry As String
With ThisWorkbook.Worksheets(cStrCountry)
' Paste list of countries from column cVntColCountries into array
vntCountries = .Range(.Cells(cLngRow1, cVntColCountries), _
.Cells(Rows.Count, cVntColCountries).End(xlUp)).Value2
' Paste list of tabs from column cVntColTabs into array
vntTabs = .Range(.Cells(cLngRow1, cVntColTabs), _
.Cells(Rows.Count, cVntColTabs).End(xlUp)).Value2
End With
' The data is in arrays instead of ranges.
' 1. According to the following line the workbook objWbMaster is already open.
' Is that true?
Set objWbMaster = Workbooks(cStrMaster)
For lngCountries = LBound(vntCountries) To UBound(vntCountries)
If vntCountries(lngCountries, 1) <> "" Then
strCountry = vntCountries(lngCountries, 1)
' Determine the path to search for files in.
strPath = Application.InputBox(Prompt:=strMsg1, _
Title:="InputBox Method", Type:=2) ' Type:=2 = text
' When Cancel is clicked in Input Box ... Exit Sub
If strPath = "False" Or IsError(strPath) Then
MsgBox strMsg2
Exit Sub
End If
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Application.ScreenUpdating = False
strFile = Dir(strPath & cStrTemplate & strCountry & "*" & cStrExt)
' VBA Help: Dir returns the first file name that matches pathname. To
' get any additional file names that match pathname, call Dir
' again with no arguments. When no more file names match, Dir
' returns a zero-length string ("").
' i.e. The approach is correct!
Do While strFile <> ""
Set ojbWbEach = Workbooks.Open(strPath & strFile)
' 2. When would this ever happen?
If Len(ojbWbEach.Name) <= 253 Then
' Add a new sheet with the file's name (remove the extension)
With objWbMaster
' 3. Isn't the blnLastSheet always False. What should it be doing?
Dim blnLastSheet As Boolean
Dim intSheetsCounter As Integer
Dim intSheets As Integer
intSheets = .Worksheets.Count
' 4. Why parentheses in ... Step (-1)?
For intSheetsCounter = intSheets To 1 Step -1
' 5. Why parentheses in (blnLastSheet)?
If (blnLastSheet) = False Then
' Place sheet at the end.
Set objWsNew = .Worksheets _
.Add(After:=.Worksheets(intSheetsCounter))
With objWsNew
.Cells(1, 1) = cStrNewHeader1
.Cells(1, 2) = cStrNewHeader2
.Cells(1, 3) = cStrNewHeader3
.Name = strCountry
End With
End If
Next
End With
Else
MsgBox strMsg3
ojbWbEach.Close False
GoTo Exit_Loop
End If
' Loop through all worksheets in ojbWbEach.
For Each objWsEach In ojbWbEach.Worksheets
With objWsEach
For lngTabs = LBound(vntTabs) To UBound(vntTabs)
If .Name = vntTabs(lngTabs) _
And objWsNew.Name = strCountry Then
' Get the first empty row in the new sheet
Set objRngEmpty = objWsNew.Cells.Find(What:="*", _
Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
' 6. I don't think that this is necessary because you added
' the headers to the New sheet so it will find the first
' row. Or am I missing something?
If Not objRngEmpty Is Nothing Then
' If find is successful.
lngPasteRow = objRngEmpty.row + 1
Else
' Find was unsuccessfull > new empty sheet.
' Should paste at the second row.
lngPasteRow = cLngRow1
End If
' if I'm right, delete all starting from "Set objRngEmpty ..."
' and delete "Dim objRngEmpty as Range" and use the following
' line:
' lngPasteRow = objWsNew.Cells.Find(What:="*", Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).row + 1
' Pasting a range into a same sized range is much faster than
' looping or copy/pasting.
objWsNew.Range(.Cells(lngPasteRow, cVntFirstCol), _
.Cells(cLngLastRow + lngPasteRow - cLngFirstRow, _
cVntLastCol)) = _
.Range(.Cells(cLngFirstRow, cVntFirstCol), _
.Cells(cLngLastRow, cVntLastCol)).Value2
End If
Next
.Close False
End With
Next
Exit_Loop:
Set ojbWbEach = Nothing
strFile = Dir
Loop
End If
Next lngCountries
Set objWsEach = Nothing
Set objWsNew = Nothing
Set objWbEach = Nothing
Set objWbMaster = Nothing
Application.ScreenUpdating = True
End Sub
Thank you again for the clean up. I made some modifications to your code and corrected some error but for some reason, it is only able to consolidate 7 countries after which excel crashes. See the code I am running below: Do you think you can find the issue?
Option Explicit
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
' ThisWorkbook
Const cStrCountry As String = "CountryName"
Const cLngRow1 As Long = 2
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntColCountries As Variant = "B"
Const cVntColTabs As Variant = "C"
Const cStrTemplate = "Screener_User_Template-"
Const cStrMaster As String = "ebele_test.xlsm"
Const cStrExt = ".xlsx"
' New Worksheet in Master Workbook
Const cStrNewHeader1 = "Identifier"
Const cStrNewHeader2 = "Company Name"
Const cStrNewHeader3 = "Country of Incorporation"
' Each Worksheet in Each Workbook
Const cLngFirstRow As Long = 3
Const cLngLastRow As Long = 150000
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntFirstCol As Variant = "A"
Const cVntLastCol As Variant = "M"
' MsgBox
Dim strMsg1 As String
strMsg1 = "Please enter only folder path in this format as " _
& "C:\Users\... Exclude the file name"
Dim strMsg2 As String
strMsg2 = "Incorrect Input. Please paste correct folder path."
Dim strMsg3 As String
strMsg3 = "Sheet's name can only be up to 253 characters long. " _
& "Shorten the Excel file name."
' Workbooks
' ThisWorkbook
Dim ojbWbEach As Workbook ' Workbook Looper
Dim objWbMaster As Workbook ' Master Workbook
' Worksheets
' ThisWorkbook.Worksheets (cStrCountry)
Dim objWsEach As Worksheet ' Worksheet Looper
Dim objWsNew As Worksheet ' New Worksheet
' Arrays Pasted From Ranges
Dim vntCountries As Variant ' List of Countries
Dim vntTabs As Variant ' List of Tabs
' Ranges
Dim objRngEmpty As Range ' New Sheet Paste Cell
' Rows
Dim lngPasteRow As Long ' New Sheet Paste Row
Dim lngCountries As Long ' Countries Counter
Dim lngTabs As Long ' Tabs Counter
' Strings
Dim strPath As String
Dim strFile As String
Dim strCountry As String
With ThisWorkbook.Worksheets(cStrCountry)
' Paste list of countries from column cVntColCountries into array
vntCountries = .Range(.Cells(cLngRow1, cVntColCountries), _
.Cells(Rows.Count, cVntColCountries).End(xlUp)).Value2
' Paste list of tabs from column cVntColTabs into array
vntTabs = .Range(.Cells(cLngRow1, cVntColTabs), _
.Cells(Rows.Count, cVntColTabs).End(xlUp)).Value2
End With
' The data is in arrays instead of ranges.
' 1. According to the following line the workbook objWbMaster is already open.
' Is that true? yeah, but I moved the strpath up because I want it to be inputed once
Set objWbMaster = Workbooks(cStrMaster)
' Determine the path to search for files in.
strPath = Application.InputBox(Prompt:=strMsg1, _
Title:="InputBox Method", Type:=2) ' Type:=2 = text
'
For lngCountries = LBound(vntCountries) To UBound(vntCountries)
If vntCountries(lngCountries, 1) <> "" And strPath <> "" Then
strCountry = vntCountries(lngCountries, 1)
' When Cancel is clicked in Input Box ... Exit Sub
If strPath = "False" Or IsError(strPath) Then
MsgBox strMsg2
Exit Sub
End If
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Application.ScreenUpdating = False
strFile = Dir(strPath & cStrTemplate & strCountry & "*" & cStrExt)
' VBA Help: Dir returns the first file name that matches pathname. To
' get any additional file names that match pathname, call Dir
' again with no arguments. When no more file names match, Dir
' returns a zero-length string ("").
' i.e. The approach is correct!
Do While strFile <> ""
Set ojbWbEach = Workbooks.Open(strPath & strFile)
' 2. When would this ever happen?
If Len(ojbWbEach.Name) <= 253 Then
' Add a new sheet with the file's name (remove the extension)
With objWbMaster
' 3. Isn't the blnLastSheet always False. What should it be doing?
Dim blnLastSheet As Boolean
Dim intSheetsCounter As Integer
Dim intSheets As Integer
intSheets = .Worksheets.Count
' 4. Why parentheses in ... Step (-1)?
For intSheetsCounter = intSheets To 1 Step -1
' 5. Why parentheses in (blnLastSheet)?
If blnLastSheet = False Then
' Place sheet at the end.
Set objWsNew = .Worksheets _
.Add(After:=.Worksheets(intSheetsCounter))
With objWsNew
.Cells(1, 1) = cStrNewHeader1
.Cells(1, 2) = cStrNewHeader2
.Cells(1, 3) = cStrNewHeader3
End With
End If
Next
End With
Else
MsgBox strMsg3
ojbWbEach.Close False
GoTo Exit_Loop
End If
' Loop through all worksheets in ojbWbEach.
For Each objWsEach In ojbWbEach.Worksheets
With objWsEach
For lngTabs = LBound(vntTabs) To UBound(vntTabs)
If .Name = vntTabs(lngTabs, 1) Then
' _
'And objWsNew.Name = strCountry
'
' Get the first empty row in the new sheet
lngPasteRow = objWsNew.Cells.Find(What:="*", Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).row + 1
' Pasting a range into a same sized range is much faster than
' looping or copy/pasting.
objWsNew.Range(objWsNew.Cells(lngPasteRow, cVntFirstCol), _
objWsNew.Cells(cLngLastRow + lngPasteRow - cLngFirstRow, _
cVntLastCol)) = _
.Range(.Cells(cLngFirstRow, cVntFirstCol), _
.Cells(cLngLastRow, cVntLastCol)).Value2
objWsNew.Name = strCountry
End If
Next
End With
Next
ojbWbEach.Close False
Exit_Loop:
Set ojbWbEach = Nothing
strFile = Dir
Loop
End If
Next lngCountries
Set objWsEach = Nothing
Set objWsNew = Nothing
Set ojbWbEach = Nothing
Set objWbMaster = Nothing
Call Module2.clean
Application.ScreenUpdating = True
End Sub
What it does is that it also creates extra blank worksheets which I have to clean up with the sub clean.
This is a code from my consolidator maybe you can get an idea.
Dim lRow As Long
Dim LastRow As Long
lRow = Sheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row
lRow = lRow + 100
LastRow = WorksheetFunction.Max(Sheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row, 9)
LastRow = LastRow + 1
sht1.Range("A10:Q" & lRow).Copy
sht2.Range("A" & LastRow).PasteSpecial
Dim rowL As Long
rowL = sht1.Range("E65536").End(xlUp).Row
sht1.Range("B7").Copy Destination:=sht2.Range("R" & LastRow)
sht1.Range("D7").Copy Destination:=sht2.Range("S" & LastRow)
I have two questions but first a bit of background...
I have a number of workbooks each containing a different number of worksheets all saved in the same folder. Each worksheet except the first has an invoice from which I need data from specific cells copied on to the master sheet.
The Master sheet has 5 columns which will be populated with the information from the same 5 cells on each sheet on the following row.
Invoice Sheets Cell Master Sheet Row
E9 A
D18 B
D22 C
E11 D
F27 E
.
Sub Consolidate()
Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim ColDest As String
Dim ColSrc As String
Dim RngDest As String
Dim RngSrc As String
Dim InvTotal As String
Dim RowInstructCrnt As Long
Dim RowSrcEnd As Long
Dim RowSrcStart As Long
Set destsheet = Workbooks("Test Master.xlsm").Worksheets("Sheet1")
'get list of all files in folder
Fname = Dir(ThisWorkbook.Path & "/*.xlsx")
'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets("Sheet1")
'find first empty row in destination table
ResultRow = destsheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
'start at top of list of cell references and work down until empty cell reached
Application.Goto ThisWorkbook.Worksheets("Sheet1").Range("D16")
With ThisWorkbook.Worksheets("Sheet1")
Do While Not IsEmpty(.Cells(16, 4))
ColSrc = .Cells(9, 5)
RowSrcStart = .Cells(18, 4)
RowSrcEnd = .Cells(22, 4)
ColDest = .Cells(11, 5)
InvTotal = .Cells(27, 6)
RngSrc = ColSrc & RowSrcStart & ColSrc & RowSrcEnd & InvTotal
RngDest = ColDest & ResultRow
originsheet.Range(RngSrc).Copy
destsheet.Range(RngDest).PasteSpecial
Loop
End With
Workbooks(Fname).Close SaveChanges:=False 'close current file
Fname = Dir 'get next file
Loop
End Sub
So my first question is - how can I modify this code to make it paste the correct information in the correct cells...
Secondly - I've not yet attempted looping through each sheet in the workbooks as I'm not sure where to begin...
Any advice would be greatly appreciated
Untested:
Sub Consolidate()
Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim RngDest As Range
Set destsheet = ThisWorkbook.Worksheets("Sheet1")
Set RngDest = destsheet.Cells(Rows.Count, 1).End(xlUp) _
.Offset(1, 0).EntireRow
Fname = Dir(ThisWorkbook.Path & "/*.xlsx")
'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
If Fname <> ThisWorkbook.Name Then
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets("Sheet1")
With RngDest
.Cells(1).Value = originsheet.Range("E9").Value
.Cells(2).Value = originsheet.Range("D18").Value
.Cells(3).Value = originsheet.Range("D22").Value
.Cells(4).Value = originsheet.Range("E11").Value
.Cells(5).Value = originsheet.Range("F27").Value
End With
wkbkorigin.Close SaveChanges:=False 'close current file
Set RngDest = RngDest.Offset(1, 0)
End If
Fname = Dir() 'get next file
Loop
End Sub