VBA - As the typical question starts, I am NEW (brand new) to VBA. I want to open a spreadsheet that will allow me to open multilple files (undetermined number) from one folder. It will then select certain cells from each file, copy and paste them into my original spreadsheet. Of course, then close all of the other files.
See if this will help. Because we're copying from an irregular (non-contiguous) range, it's a bit difficult to copy to another irregular range. So for that reason, the target range is "A1,B1,C1,D1,E1, etc", instead of "A1,B1,C1,E1,H1, etc". If that doesn't work for you, we'll need to try something a bit more elaborate.
Sub copyMultFiles()
Dim rS As Range, rT As Range, Cel As Range
Dim wBs As Workbook 'source workbook
Dim wS As Worksheet 'source sheet
Dim wT As Worksheet 'target sheet
Dim x As Long 'counter
Dim c As Long
Dim arrFiles() As String 'list of source files
Dim myFile As String 'source file
' change these to suit requirements
Const csMyPath As String = "C:\Documents and Settings\Dave\Desktop\TestFolder\" 'source folder
Const csMyFile As String = "*.xls" 'source search pattern
Const csSRng As String = "$C$1,$C$10,$C$11,$C$34,$D$1" 'source range
Const csTRng As String = "$A$1" 'target range
Application.ScreenUpdating = False
' target sheet
Set wT = ThisWorkbook.Worksheets(1) 'change to suit
' clear sheet
wT.Cells.Clear 'may not want this, comment out!!!
' aquire list of files
ReDim arrFiles(1 To 1)
myFile = Dir$(csMyPath & csMyFile, vbNormal)
Do While Len(myFile) > 0
arrFiles(UBound(arrFiles)) = myFile
ReDim Preserve arrFiles(1 To UBound(arrFiles) + 1)
myFile = Dir$
Loop
ReDim Preserve arrFiles(1 To UBound(arrFiles) - 1)
Set rT = wT.Range(csTRng)
' loop thru list of files
For x = 1 To UBound(arrFiles)
Set wBs = Workbooks.Open(csMyPath & arrFiles(x), False, True) 'open wbook
Set wS = wBs.Worksheets(1) 'change sheet to suit
c = 0
Set rS = wS.Range(csSRng)
'copy source range to current target row
For Each Cel In rS
Cel.Copy rT.Offset(, c) 'next column
c = c + 1
Next Cel
wBs.Close False
Set rT = rT.Offset(1) 'next row
DoEvents
Next x 'next book
Erase arrFiles
Application.ScreenUpdating = True
End Sub
Related
I have a workbook that generates pages/page names. The worksheet name always reflects a job number. The job number is also always displayed in cell A1.
I want to copy data from another book, and paste it back into this worksheet, but I need to target the page I want to paste the data.
My issue is that I can't say wbkDest.Worksheets("sheet1").
I need to say something like wbk.Dest.Worksheets(Range("a1").value).
So again: Paste in the sheet with the same name as cell A1 in the workbook the macro is triggered from.
sub import()
Dim wbkSrc As Workbook, wbkDest As Workbook
Dim myFile As String
Dim Path As String
Dim emptyRow As Long
Dim wsOrig As Worksheet
Set wsOrig = ThisWorkbook.Worksheets(1)
emptyRow = 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbkDest = Workbooks("lathe_project6-1-2017.xlsm")
Path = "G:\FIXTURES\" & Range("A1").Value & "\lists\new folder\"
myFile = Dir(Path & "*.xls??")
Set wbkSrc = Workbooks.Open(Path & myFile)
wbkSrc.Worksheets(1).Range("A1:I100").Copy
wbkDest.Worksheets(wsOrig.Range("A1").Value).Cells(emptyRow, 1).PasteSpecial Paste:=xlPasteValues
wbkSrc.Close
End Sub
This doesn't work:?
Dim wskVariableSheet as worksheet
Set wskVariableSheet = wbkDest.Sheets(Range("a1").Value)
And then just reference to wskVariableSheet.range where you want to paste.
I've got about 15 workbooks, each having roughly 5000 sheets with data in cell "A1" to "Z1" data. I need to compile all of these sheets into one file named 'compiled'.
Put simply, there is one row of data per sheet across 15 xlsm files. All these rows need to be compiled to one sheet.
The challenge however, is in cell "A1" of every sheet within the 15 workbooks contains a code number eg."12345A", "B1" has some data and "C1" some data.
Some sheets share "A1", "B1", "C1" data. So when copying data from these sheets the VBA code needs to check if a row that has this "A1", "B1", "C1" data has already been copied and copy only "D1" to "AB1" beneath that particular row.
Sample sheet
Sample compiled
Private Sub Compiled()
Dim thisWS As Worksheet, sheet As Worksheet
Dim compiled As Workbook, thatWB As Workbook
Dim path As String, fileName As String, compiledpath As String
path = "C:\Users\User\Desktop\New folder\"
fileName = Dir(path & "*.xlsm")
compiledpath = "C:\Users\User\Desktop\compiled.xlsm"
Set compiled = Workbooks(compiledpath)
Set thisWS = compiled.Sheets("List")
Dim arr(75000) As String
Dim counter As Long
counter = 0
Do While Len(fileName) > 0
Set thatWB = Workbooks.Open(path & fileName, True, True)
For Each sheet In thatWB.Sheets
arr(counter) = thatWB.sheet.Range("A1").Value
Next sheet
counter = counter + 1
thatWB.Close Flase
fileName = Dir()
Loop
thisWS.Range(thisWS.Cells(1, 1), thisWS.Cells(coutner, 1)).Value2 = arr
End Sub
Have fun :P
Private Sub this()
Dim path As String, fileName as string
path = "c:\"
fileName = Dir(path & "*.xl??")
dim thisWS as worksheet, sheet as worksheet
set thisWS = ThisWorkbok.Sheets("Sheet1")
dim thatWB as workbook
dim arr(75000) as string
dim counter as long
counter = 0
Do While Len(fileName)>0
Set thatWB = WorkBooks.Open(path & fileName, True, true)
For Each sheet in thatWB.Sheets
arr(counter) = thatWB.sheet.Range("A1").Value
next sheet
counter = counter + 1
thatWB.close Flase
fileName = Dir()
Loop
thisWS.Range(thisWS.Cells(1,1), thisWS.Cells(coutner,1).Value2 = arr
End Sub
I have a macro here that consolidates all files into a master file. Currently this copies the entire worksheet from each file and stacks it into the master file. This ideal code will go into source file and find the header row and copy below. The header row is not static. Sometimes its on Row 5, sometimes row 15. There is data above the header and its usually long text strings.
How do I edit the below code to do that?
Thanks In Advance!
Here is the Code:
Sub Consolidate_BST()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim sourceRange As Range
Dim destrange As Range
Worksheets("Consolidate BSts").Range("A1:J50000").ClearContents
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = ThisWorkbook.Sheets("Consolidate BSts")
' Modify this folder path to point to the files you want to use. 'M
FolderPath = "C:\Users\413315\Documents\\March Bluesheets"
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")
' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName
' Modify this range for your workbooks.
' It can span multiple rows.
Set sourceRange = WorkBk.Worksheets("Regional Estimates").Range("B3:J1000")
' Set the destination range to start at column B and
' be the same size as the source range.
Set destrange = SummarySheet.Range("B" & NRow)
Set destrange = destrange.Resize(sourceRange.Rows.Count, _
sourceRange.Columns.Count)
' Copy over the values from the source to the destination.
destrange.Value = sourceRange.Value
' Increase NRow so that we know where to copy data next.
NRow = NRow + destrange.Rows.Count
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()
Loop
SummarySheet.Columns.AutoFit
Worksheets("Consolidate BSts").Range("D2:D50000").ClearContents
End Sub
Assuming that the header is always in the same column, you could add something like the following to the top of your code:
Dim cond As Boolean
Dim headerRow As Integer, i As Integer
cond = False
While cond <> True
i = i + 1
If sourceRange.Cells(i, 1) = "Name of Header" Then 'For a header in column A
i = headerRow
cond = True
End If
Wend
Then with you should be able to modify the range of data that it intakes based on what row the headers are in.
Also you could change the if statement to something more general, but it's hard to know what it should be without knowing what your headers and data look like.
(Previous Post)
I need to create a macro that loops through the files that are in a single folder and runs the code that I have provided below. All the files are structured the same way however, have different data. The code helps me go to a specified destination file and counts the number of "YES" in the column. Then it outputs it into a CountResults.xlsm (master workbook). I have the following code with the help of Zac:
Private Sub CommandButton1_Click()
Dim oWBWithColumn As Workbook: Set oWBWithColumn = Application.Workbooks.Open("C:\Users\khanr1\Desktop\CodeUpdateTest\Test01.xlsx")
Dim oWS As Worksheet: Set oWS = oWBWithColumn.Worksheets("Sheet2")
ThisWorkbook.Worksheets("Sheet1").Range("B2").Value = Application.WorksheetFunction.CountIf(oWS.Range("B:B"), "YES")
oWBWithColumn.Close False
Set oWS = Nothing
Set oWBWithColumn = Nothing
End Sub
This is what the CountResults.xlsm (Master Workbook) looks like:
And, this is an example of what the Test01.xlsx looks like:
To note, there are 10 test files (Test01, Test02...) but the code should be able to update any new test files added (ex. Test11, Test12...). I had an idea of incorporating the "Files" column in the first image to pull the file names and loop them.
The easiest way to do so would be to use the filesystemobject to loop through all the files in the folder and find the ones where filename is similar to the predetrmined mask( in your case "Test*.xslx"). Please note that it also goes through subfolders in the specified folder. If that is not required, omit the first for each loop:
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim oWBWithColumn As Workbook
Dim oWbMaster as workbook
Dim oWsSource as worksheet
Dim oWsTarget as worksheet
Dim Mask As String
Dim k as long
k=2
Set oWbMaster = ActiveWorkbook
Set oWsTarget = oWbMaster.Sheets("Sheet1")
Set fso = CreateObject("scripting.FileSystemObject")
Set fldStart = fso.GetFolder("C:\Users\khanr1\Desktop\CodeUpdateTest\")
Mask = "Test*" & ".xlsx"
For Each fld In fldStart.Subfolders
For Each fl In fld.Files
If fl.Name Like Mask Then
Set oWBWithColumn = Application.Workbooks.Open(Filename:=fld.Path & "\" & fl.Name, ReadOnly:=True)
Set oWsSource = oWBWithColumn.Worksheets("Sheet2")
oWsTarget.Range("B"& k).Value = Application.WorksheetFunction.CountIf(oWsSource.Range("B:B"), "YES")
oWBWithColumn.Close SaveChanges:=False
k = k+1
End If
Next
Next
If this answer helps, please mark as accepted. Also note that your original code would replace the value of B2 cell in the master spreadsheet every iteration of the loop, that's why I have added the k variable to change the target cell after each iteration
P.S.
You can generate a list of files along with the yes counts from the folder all at the same time, just add this line to the code before closing the file:
oWsTarget.Range("A"& k).Value= fl.Name
The easiest thing to do is convert your code into a function.
Private Sub CommandButton1_Click()
Dim r As Range
With Worksheets("Sheet1")
For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
r.Offset(0, 1).Value = getYesCount(r.Value)
Next
End With
End Sub
Function getYesCount(WorkBookName As String) As Long
Const FolderPath As String = "C:\Users\khanr1\Desktop\CodeUpdateTest\"
If Len(Dir(FolderPath & WorkBookName)) Then
With Workbooks.Open(FolderPath & WorkBookName)
With .Worksheets("Sheet2")
getYesCount = Application.CountIf(.Range("B:B"), "YES")
End With
.Close False
End With
Else
Debug.Print FolderPath & WorkBookName; ": Not Found"
End If
End Function
I'm trying to use a for-loop to pick up data from multiple files, but somehow either the single cell range or the named range are not working:
Sub GetTTData()
' Original from:
' http://ccm.net/faq/24666-excel-vba-copy-data-to-another-workbook
' CopyOpenItems Macro
' Copy open items to sheet.
'
' Keyboard Shortcut: Ctrl+Shift+O
'
Dim wbReport As Workbook 'workbook where the data is to be pasted
Dim wbTTData As Workbook 'workbook from where the data is to copied
Dim strName As String 'name of the source sheet/ target workbook
Dim fileName As String
Dim RAWDataSheet As Worksheet
Dim SourceDataSheet As Worksheet
Dim RAWData As Range
Dim SourceData As Range
Dim portName As String
Dim rCell As Range
Dim files As Range
'set to the current active workbook (the source book)
Set wbReport = ThisWorkbook
'select Departure Airport
portName = Worksheets("Control").Range("Dep_Airport")
Set files = Worksheets("Control").Range("All_Files")
'select cell A2 on the target book
Set RAWDataSheet = wbReport.Worksheets("RAW TT Data")
RAWDataSheet.Activate
Set RAWData = RAWDataSheet.Range(Range("A2"), ActiveCell.SpecialCells(xlLastCell))
'clear existing values form target book
RAWData.ClearContents
For Each rCell In Range("files")
'take source of TT Data from workbook and open file
fileName = Worksheets("Control").Range("File_Path") + Worksheets("Control").Range("rCell")
Set wbTTData = Workbooks.Open(fileName)
'activate the source book
wbTTData.Activate
'clear any thing on clipboard to maximize available memory
Application.CutCopyMode = False
'copy the range from source book
Set SourceDataSheet = wbTTData.Sheets("Sheet1")
'filter RAW TT Data for Departure Airport
Set RAWData = SourceDataSheet.Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell))
RAWData.AutoFilter Field:=3, Criteria1:=Array(portName), Operator:=xlFilterValues
Set SourceData = SourceDataSheet.Range(Range("A2"), ActiveCell.SpecialCells(xlLastCell))
SourceData.Copy
'paste the data on the target book
RAWDataSheet.Range("A2").PasteSpecial
'clear any thing on clipboard to maximize available memory
Application.CutCopyMode = False
'save the target book
wbReport.Save
'close the workbook
wbTTData.Close savechanges:=False
Next rCell
'activate the source book again
wbReport.Activate
'clear memory
Set wbReport = Nothing
Set wbTTData = Nothing
Set SourceDataSheet = Nothing
Set SourceData = Nothing
End Sub
You have this variable:
Dim files As Range
And then you set it here:
Set files = Worksheets("Control").Range("All_Files")
Then when you begin your loop your code is:
For Each rCell In Range("files")
I think you mean for your code to read:
For Each rCell In files