Copy columns from one workbook to another - excel

I want to fill in the workbook that holds the macro with data from another workbook. The data I need to copy can be on different columns on the source file, depending on the way this source file is generated. So I may run into a problem, because I might get the data I want on a wrong column, or I may even get data I do not want. So I guess it's better to look for the column header (which are always the same string, no matter how the report is generated). I can use the Find method to search for the headers, but how to copy the rows below each header? The range where I want the data pasted are always the same ranges on the paste workbook, and always the first sheet.
Following is my current code:
Sub Import()
' Looks up for the Source Report file and imports its data into wkbk that holds the macro
On Error Resume Next
' Defines Source Report file variable
Dim SourceFile As Variant
' Opens the SourceFile
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
End If
SourceFileDir = Dir(SourceFile)
' Looks up the last row on SourceFile to copy the entire data later
With Workbooks(SourceFileDir).Worksheets(1)
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
' MsgBox ("The last row of data in the Source File is " & LastRow)
' Sets echo off before copying
Application.ScreenUpdating = False
' Copies SourceFile data into paste file, the one that holds the macro
' Serial Number
Workbooks(SourceFileDir).Worksheets(1).Range("E7:E" & LastRow).Copy
ThisWorkbook.Worksheets(1).Range("A38").PasteSpecial xlPasteValues
' Product ID
Workbooks(SourceFileDir).Worksheets(1).Range("A7:A" & LastRow).Copy
ThisWorkbook.Worksheets(1).Range("B38").PasteSpecial xlPasteValues
' Gets out of copy mode
Application.CutCopyMode = False
' Sets echo back on
Application.ScreenUpdating = True
End Sub
The total number of columns I need is 9, the code above just shows two of them, Serial Number and Product ID.
Thanks for your help.

Workbook to Workbook
Adjust the values in the constants section and right below in the Headers array.
Option Explicit
Sub Import()
' Looks up for the Source Report file and imports its data into
' wkbk that holds the macro
Const LastRowColumnS As Long = 1
Const FirstRowS = 7
Const FirstRowP = 38
Dim Headers As Variant
Headers = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
Dim rng As Range
Dim SourceFile As Variant
Dim wsS As Worksheet
Dim wsP As Worksheet
Dim LastRowS As Long
Dim CurColS As Long
Dim CurColP As Long
Dim NumberOfRows As Long
Dim Count As Long
Dim i As Long
' Opens Source File.
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename( _
FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
Else
MsgBox "You selected cancel."
Exit Sub
End If
' Define worksheets.
Set wsS = ActiveWorkbook.Worksheets(1)
Set wsP = ThisWorkbook.Worksheets(1)
' Define last cell with data in Last Row Column of Source Sheet.
Set rng = wsS.Columns(LastRowColumnS).Find( _
What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rng Is Nothing Then
MsgBox "No data in column."
Exit Sub
End If
NumberOfRows = rng.Row - FirstRowS + 1
For i = 0 To UBound(Headers)
' Define column of Current Header in Source Sheet.
Set rng = wsS.Cells.Find(What:=Headers(i), _
After:=wsS.Cells(wsS.Rows.Count, wsS.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColS = rng.Column
' Define column of Current Header in Paste Sheet.
Set rng = wsP.Cells.Find(What:=Headers(i), _
After:=wsP.Cells(wsP.Rows.Count, wsP.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColP = rng.Column
' Write data from Source Sheet to Paste Sheet.
wsP.Cells(FirstRowP, CurColP).Resize(NumberOfRows).Value _
= wsS.Cells(FirstRowS, CurColS).Resize(NumberOfRows).Value
' Count the transfer.
Count = Count + 1
End If
End If
Next i
' Maybe close Source Workbook.
'wsS.Parent.Close False
MsgBox "Transferred data from '" & Count & "' columns."
End Sub
EDIT:
Since some of the headers have different values (names) on each sheet you should use two arrays (one for each sheet) and adjust the values appropriately:
Option Explicit
Sub Import()
' Looks up for the Source Report file and imports its data into
' wkbk that holds the macro
Const LastRowColumnS As Long = 1
Const FirstRowS = 7
Const FirstRowP = 38
Dim HeadSource As Variant
Dim HeadPaste As Variant
HeadSource = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
HeadPaste = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
Dim rng As Range
Dim SourceFile As Variant
Dim wsS As Worksheet
Dim wsP As Worksheet
Dim LastRowS As Long
Dim CurColS As Long
Dim CurColP As Long
Dim NumberOfRows As Long
Dim Count As Long
Dim i As Long
' Opens Source File.
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename( _
FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
Else
MsgBox "You selected cancel."
Exit Sub
End If
' Define worksheets.
Set wsS = ActiveWorkbook.Worksheets(1)
Set wsP = ThisWorkbook.Worksheets(1)
' Define last cell with data in Last Row Column of Source Sheet.
Set rng = wsS.Columns(LastRowColumnS).Find( _
What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rng Is Nothing Then
MsgBox "No data in column."
Exit Sub
End If
NumberOfRows = rng.Row - FirstRowS + 1
For i = 0 To UBound(HeadSource)
' Define column of Current Header in Source Sheet.
Set rng = wsS.Cells.Find(What:=HeadSource(i), _
After:=wsS.Cells(wsS.Rows.Count, wsS.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColS = rng.Column
' Define column of Current Header in Paste Sheet.
Set rng = wsP.Cells.Find(What:=HeadPaste(i), _
After:=wsP.Cells(wsP.Rows.Count, wsP.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColP = rng.Column
' Write data from Source Sheet to Paste Sheet.
wsP.Cells(FirstRowP, CurColP).Resize(NumberOfRows).Value _
= wsS.Cells(FirstRowS, CurColS).Resize(NumberOfRows).Value
' Count the transfer.
Count = Count + 1
End If
End If
Next i
' Maybe close Source Workbook.
'wsS.Parent.Close False
MsgBox "Transferred data from '" & Count & "' columns."
End Sub

Related

How can I select only some specific Data when Using Last Row?

I would Like to only copy the information in Range A2:P13. This Data gets spit out In different rows from time to time, and some times additional data in some of the columns gets added. I wrote a script that allows me to Select and copy everything from the last row to an x number rows up. Problem is that this amount of rows can be variable And there is way more data above the shared image (its clutter). Is there a way to modify my script so it counts down to the last row and once it hits "n" or "Calibration" it selects 8 rows above it?
Thanks in advance :)
enter image description here
Option Explicit
Sub Import_File()
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim myValue As Variant
Dim Sht2 As Worksheet
Dim lastRow As Long
Dim Last24Rows As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
myValue = InputBox("Please Input Run Number")
FileToOpen = Application.GetOpenFilename("Excel Files (*.xl*),*.xl*", , "Choose File", "Open", False)
If FileToOpen = False Then
Exit Sub
Else
Set OpenBook = Workbooks.Open(FileToOpen)
Set Sht2 = OpenBook.Sheets("Sheet1")
End If
lastRow = Sht2.Range("H" & Sht2.Rows.Count).End(xlUp).row
Set Last4Rows = Sht2.Range("A" & lastRow - 4 & ":AZ" & lastRow)
Last4Rows.Copy
ThisWorkbook.Worksheets(myValue).Range("A1").PasteSpecial xlPasteValues
OpenBook.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I tried Including this
' Dim wb As Workbook
' Dim ws As Worksheet
' Dim FoundCell As Range
' Set wb = ActiveWorkbook
' Set ws = ActiveSheet
'
' Const WHAT_TO_FIND As String = "Calibration"
'
' Set FoundCell = ws.Range("A:A").Find(What:=WHAT_TO_FIND)
' If Not FoundCell Is Nothing Then
' MsgBox (WHAT_TO_FIND & " found in row: " & FoundCell.Row)
' Else
' MsgBox (WHAT_TO_FIND & " not found")
' End If
But it did not work
This will select 8 rows above wherever it finds "calibration". The -8 makes it move up 8 rows, and then the resize(8) resizes it to include the 8 rows below. It will create an error if it can't find "calibration", it would be easy to change that to send a text box instead.
Sub Macro1()
'
' Macro1 Macro
'
'
Dim found As Range
Dim SelectionRange As Range
Dim what_to_find As String
Dim FoundRow As Long
what_to_find = "calibration"
Set found = Cells.Find(What:=what_to_find, After:=ActiveCell, LookIn:=xlFormulas2, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
FoundRow = found.row
Set SelectionRange = Rows(FoundRow - 8).Resize(8)
SelectionRange.Select
End Sub

Excel VBA Loop through files with a given String

I need to create an Excel VBA Macro that is able to Loop through some Files and if it finds the given String it should fill the Excel Worksheet where I need to.
Currently it looks like this: I show a UserForm that has a TextBox where the String gets entered and a Button.
If the User clicks on that Button then the files should get looped through and if it finds the string in one of that files it should enter something new to the excel where the macro is called from.
I have searched on SO but with no Luck, I found this:
Sub LoopThroughFiles()
Dim StrFile As String
StrFile = Dir("C:\Users\xxx\xxx\xxx\test\*test*")
Do While Len(StrFile) > 0
Debug.Print StrFile
StrFile = Dir
Loop
End Sub
But this looks like it loops and looks if the filename has test in it and not if the actual file has a Value that is called "test".
Also the string that needs to be found is always in the first column of the files. And I would have to read the second column in that activeCell that I would get if the String is found and add that to the Excel where I call this Macro from.
Sincerly Faded ~
Edit:
Sub ReadDataFromAnotherWorkBook()
' Open Workbook A with specific location
Dim src As Workbook
Set src = Workbooks.Open("C:\Users\xxx\Desktop\xxx\test\x1x.xlsx", True, True)
Dim valueBookA As String
Dim valueBookB As Integer
valueBookA = src.Worksheets("Tabelle1").Cells(2, 1) ' Works but here I need to put the enteredValue and search for it
Cells(1, 1).Value = valueBookA
' Close Workbooks A
src.Close False
Set src = Nothing
' Dialog Answer
MsgBox valueBookA
End Sub
This gives me a Value from the read Excel which is good as a first start. I need to loop that to open up more files and also I need the part where I can search for the given String and get the value in that row.
Edit2:
This is what I have now but I cant get the value.. what am I doing wrong :/
Sub ReadDataFromAnotherWorkBook()
Dim SearchString As String
Dim SearchRange As Range, cl As Range
Dim FirstFound As String
Dim sh As Worksheet
' Open Workbook A with specific location
Dim src As Workbook
Set src = Workbooks.Open("C:\Users\x\Desktop\xxx\test\xxx.xlsx", True, True)
' Set Search value
SearchString = TextBox1.Value ' TEST mit TextBox Value -- works
Application.FindFormat.Clear
' loop through all sheets
For Each sh In src.Worksheets
' Find first instance on sheet
Set cl = sh.Cells.Find(What:=SearchString, _
After:=sh.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cl Is Nothing Then
' if found, remember location
FirstFound = cl.Address
MsgBox FirstFound
' format found cell
Do
' cl.Font.Bold = True
' cl.Interior.ColorIndex = 3
Debug.Print FirstFound
MsgBox FirstFound ' Does not work..
' Debug.Print cl.Value
MsgBox cl.Value ' Also does not work -- I need the VALUE that is in the Excel Row or Column where the string gets found
' find next instance
Set cl = sh.Cells.FindNext(After:=cl)
' repeat until back where we started
Loop Until FirstFound = cl.Address
End If
Next
MsgBox "Value in Excel? : " + FirstFound 'cl.Value > Is empty..
MsgBox "SEARCHSTRING :: " + SearchString ' Gives me the right String
' Close Workbooks A ' Closes the Workbook
src.Close False
Set src = Nothing
End Sub
Use Dir to loop over the files in turn
Sub SearchFiles()
Const FOLDER = "C:\Users\xxx\Desktop\xxx\test\"
Dim wb As Workbook, wbSrc As Workbook
Dim ws As Worksheet, wsSrc As Worksheet
Dim sText As String, sFilename As String
Dim cell As Range, rng As Range
Dim n As Long, i As Long, FirstFound As String
sText = TextBox1.Value
' location of search results
Set wb = ThisWorkbook
Set ws = wb.Sheets(1) ' results of search
ws.Cells.Clear
ws.Range("A1:B1") = Array("Search Test = ", sText)
ws.Range("A2:C2") = Array("Address", "Col A", "Col B")
ws.Range("A2:C2").Font.Bold = True
i = 3
' scan all xlsx files in folder
sFilename = Dir(FOLDER & "*.xlsx")
Do While Len(sFilename) > 0
Set wbSrc = Workbooks.Open(FOLDER & sFilename, True, True)
For Each wsSrc In wbSrc.Sheets
n = n + 1
Set rng = wsSrc.Columns(1)
Set cell = rng.Find(What:=sText, _
After:=rng.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
' text found
If Not cell Is Nothing Then
FirstFound = cell.Address
Do ' update sheet
ws.Cells(i, 1) = cell.Address(0, 0, xlA1, True)
ws.Cells(i, 2) = cell
ws.Cells(i, 3) = cell.Offset(0, 1)
i = i + 1
Set cell = rng.FindNext(After:=cell)
' repeat until back where we started
Loop Until FirstFound = cell.Address
End If
Next
wbSrc.Close
sFilename = Dir
Loop
MsgBox n & " sheets scanned", vbInformation
End Sub

How to make a loop to ctrl+f every value in a column?

I am trying to make a macro to insert a new column after the last occupied column in a sheet, then search for the column title "Part Number" in my example and Ctrl+F search for each string listed in the column, and search for it in another workbook. If the string is found in that workbook, I want "Found in 'Workbook Name'" to be filled in the same row as the part number it just searched for but the column that was created at the beginning. This is a part of a larger function so I am passing all the variables in including what's being searched for 'colTitle1', the book and sheet the values are on, 'BOM', the sheet "BOMSheet", and the document being searched 'SearchDoc".
The main function is here:
Public Sub OCCLCheck(colTitle As String, BOM As Workbook, BOMSheet As Worksheet)
Dim OCCL As Variant
Dim OpenBook As Workbook
Dim pn As Variant
Dim lastRow As Integer
'Counts number of rows in Column A with content
lastRow = WorksheetFunction.CountA(Range("A:A"))
'Flashy but not good for regular use - uncomment when not showing off product
'Application.ScreenUpdating = False
'Code for user to indicate the OCCL doc with a file path box - add something to prompt again if cancelled
OCCL = Application.GetOpenFilename(Title:="Choose OCCL File", FileFilter:="Excel Files (*.xls*),*xls*")
If OCCL <> False Then
Set OpenBook = Application.Workbooks.Open(OCCL)
'OpenBook.Sheets(1).Range("A1:E20").Copy
End If
'Application.ScreenUpdating = True
Call SearchFunc("Part Number", BOM, BOMSheet, OCCL)
End Sub
The search function is here:
Public Sub SearchFunc(colTitle1 As String, BOM As Workbook, BOMSheet As Worksheet, SearchDoc As Workbook)
Dim pn As String
Dim colTitle2 As String
Dim c As Variant
Dim lastRow As Integer
'Code to search for something on something else, made for searching across books
'Find the column with colTitle1
With ActiveSheet.UsedRange
Set c = .find(colTitle1, LookIn:=xlValues)
If Not c Is Nothing Then
pn = ActiveSheet.Range(c.Address).Offset(1, 0).Select
End If
End With
'Count number of rows to iterate search through
lastRow = WorksheetFunction.CountA(Range("A:A"))
For i = 1 To lastRow
If Cells.find(What:=Workbooks(BOM).Worksheets(BOMSheet).Range(i, 2).Value, After:=ActiveCell, _
LookIn:=Workbooks(SearchDoc).Worksheets(1).xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate <> .Range(i, 2).Value Then 'Write not on occl to first unoccupied column also add code to find unoccupied column before this loop
End If
End Sub
I am pretty lost at where to go now as I know what I want to do but I am new to VBA so getting the program to do it is my problem ATM, any suggestions are appreciated!
This is the error with the macro searching for const "Part Number"
[3
Most of the essential parts needed to build your solution should be within this script. I used xlWhole in the Find so that ABC1 would not match ABC10 but if part numbers are fixed length maybe xlPart is OK. Refactor into smaller subs and functions as necessary.
Option Explicit
Sub macro()
Const COL_TITLE = "Part Number"
Dim wb As Workbook, ws As Worksheet, found As Range
Dim wbSearch As Workbook, wsSearch As Worksheet
Dim rng As Range, iResultCol As Integer, iPartCol As Integer
Set wb = ThisWorkbook
Set ws = wb.Sheets("BOM D6480000005")
' headers
Set rng = ws.UsedRange.Rows(1)
' determine part number col
Set found = rng.Find(COL_TITLE, , xlValues, xlPart)
If found Is Nothing Then
MsgBox "Can't find " & COL_TITLE, vbCritical, "Search failed"
Exit Sub
End If
iPartCol = found.Column
' determine last col
iResultCol = rng.Columns.count + rng.Column
ws.Cells(1, iResultCol) = "Search Result"
Debug.Print rng.Address, iPartCol, iResultCol
Dim sFilename As String
sFilename = Application.GetOpenFilename(Title:="Choose OCCL File", FileFilter:="Excel Files (*.xls*),*xls*")
If Len(sFilename) > 0 Then
Set wbSearch = Application.Workbooks.Open(sFilename)
Else
MsgBox "No file chosen", vbExclamation
Exit Sub
End If
' find last row
Dim iLastRow As Long, iRow As Long, sPartNo As String, count As Long
iLastRow = ws.Cells(Rows.count, iPartCol).End(xlUp).Row
Debug.Print "iLastRow", iLastRow
' search each sheet
For Each wsSearch In wbSearch.Sheets
For iRow = 2 To iLastRow
sPartNo = ws.Cells(iRow, iPartCol)
If Len(sPartNo) > 0 Then
Set found = wsSearch.UsedRange.Find(sPartNo, , xlValues, xlWhole)
If found Is Nothing Then
' not found
Else
ws.Cells(iRow, iResultCol) = "Found in " & wbSearch.Name & _
" " & wsSearch.Name & _
" at " & found.Address
count = count + 1
End If
End If
Next
Next
' end
wbSearch.Close False
MsgBox count & " matches", vbInformation, "Finished"
End Sub

Looping through worksheets in a workbook and consolidating each workbook in to a worksheet in the master workbook

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)

How can I get the specific worksheet in multiple workbook?

For example,
I have 10 classes' exam result.
Each class have their own workbook.
Each workbook have 3 worksheet : English Result, Math Result and Physics Result
How can I get all the Math Result from all the classes and combine it to 1 worksheet?
I tried to write an If-statement to do it but there are some errors.
The code I currently using can only get the result from the workbook that have only 1 worksheet.
Please help me!
Here are the codes I current using:
Sub CombineDataFiles()
Dim DataBook As Workbook, OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim TargetFiles As FileDialog
Dim MaxNumberFiles As Long, FileIdx As Long, _
LastDataRow As Long, LastDataCol As Long, _
HeaderRow As Long, LastOutRow As Long
Dim DataRng As Range, OutRng As Range
'initialize constants
MaxNumberFiles = 2001
HeaderRow = 1 'assume headers are always in row 1
LastOutRow = 1
'prompt user to select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
.AllowMultiSelect = True
.Title = "Multi-select target data files:"
.ButtonName = ""
.Filters.Clear
.Show
End With
'error trap - don't allow user to pick more than 2000 files
' Can Modify By Changing the 2000
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
Exit Sub
End If
'set up the output workbook
Set OutBook = Workbooks.Add
Set OutSheet = OutBook.Sheets(1)
'loop through all files
For FileIdx = 1 To TargetFiles.SelectedItems.Count
'open the file and assign the workbook/worksheet
Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
Set DataSheet = DataBook.ActiveSheet
'identify row/column boundaries
LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
'if this is the first go-round, include the header
If FileIdx = 1 Then
Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol))
Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol))
'if this is NOT the first go-round, then skip the header
Else
Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol))
Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
End If
'copy the data to the outbook
DataRng.Copy OutRng
'close the data book without saving
DataBook.Close False
'update the last outbook row
LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
' On Error Resume Next
' Range (A1;K100000).Select
' Selection
Next FileIdx
'let the user know we're done!
MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " files!")
End Sub
if I understand you right, you want to consolidate lists of data of the same shape (same number and order of columns) from different workbooks. Microsoft has a nice documentary on this:
https://msdn.microsoft.com/en-us/library/cc793964(v=office.12).aspx

Resources