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
Related
I tried to merge the workbooks by browsing and selecting multiple workbooks time and getting all data in current workbook. I need all data of selected workbooks in 1 sheet.But my code gives in different sheets of current workbook. sheets.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count) as per this line,syntax allowing me to opt either after or before but not giving current. pls help me out
Dim files, i As Integer
Dim dailogbox As FileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim sheets As Worksheet
Set mainWorkbook = Application.ActiveWorkbook
Set dailogbox = Application.FileDialog(msoFileDialogFilePicker)
dailogbox.AllowMultiSelect = True
files = dailogbox.Show
For i = 1 To dailogbox.SelectedItems.Count
Workbooks.Open dailogbox.SelectedItems(i)
Set sourceWorkbook = ActiveWorkbook
For Each sheets In sourceWorkbook.Worksheets
sheets.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
Next tempWorkSheet
sourceWorkbook.Close
Next i
As you have discovered, Sheets.Copy will copy or move the entire sheet. It will not merge the data into another sheet. You will have to copy the cells of the sheet you want to copy,
dim dest as Range
For i = 1 To dailogbox.SelectedItems.Count
Workbooks.Open dailogbox.SelectedItems(i)
Set sourceWorkbook = Workbooks.Open(dailogbox.SelectedItems(i))
For Each aSheet In sourceWorkbook.Worksheets '
set dest = mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
aSheet.Cells.Copy dest.Cells
Next sheets ' NOT "tempWorkSheet"
sourceWorkbook.Close
Next i
Also: "Sheets" is a reserved word. You can't use it as a variable. I changed it to "aSheet".
EDIT: To copy the formatting after copying the text, add this after aSheet.Cells.Copy dest.Cells:
dest.PasteSpecial Paste:=xlPasteFormats
This will open a file dialog allowing you to select multiple files, it will then cycle through each sheet on the work books, copy the data from A2 to the bottom right corner of your data, and paste it in the workbook that hosts this code.
Things you will need to modify or amend for:
1) The sheet name of your book that hosts this code
2) The Col span (A-Z right now)
3) If your import books have multiple sheets, you need to set a criteria for which sheets you want to import since this will grab every sheet from every selected workbook.
4) This assumes Col A does not have any blanks (to determine last row (what range to copy) you need to pick a column that is least likely to have blanks so you dont miss data.
Option Explicit
Sub Consolidation()
Dim CurrentBook As Workbook
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets("SHEETNAME?")
Dim IndvFiles As FileDialog
Dim FileIdx As Long
Dim i As Integer, x As Integer
Set IndvFiles = Application.FileDialog(msoFileDialogOpen)
With IndvFiles
.AllowMultiSelect = True
.Title = "Multi-select target data files:"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Show
End With
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For FileIdx = 1 To IndvFiles.SelectedItems.Count
Set CurrentBook = Workbooks.Open(IndvFiles.SelectedItems(FileIdx))
For Each Sheet In CurrentBook.Sheets
Dim LRow1 As Long
LRow1 = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
Dim LRow2 As Long
LRow2 = CurrentBook.ActiveSheet.Range("A" & CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row
Dim ImportRange As Range
Set ImportRange = CurrentBook.ActiveSheet.Range("A2:Z" & LRow2)
ImportRange.Copy
WS.Range("A" & LRow1 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next
CurrentBook.Close False
Next FileIdx
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
maybe you're after this (explanations in comments):
Option Explicit
Sub CopySheets()
Dim files As Variant, i As Long
Dim dailogbox As FileDialog
Dim mySheet As Worksheet, targetSheet As Worksheet
Set targetSheet = ActiveSheet ' set the sheet you want to collect selecte workbooks worksheets data into
Set dailogbox = Application.FileDialog(msoFileDialogFilePicker)
dailogbox.AllowMultiSelect = True
files = dailogbox.Show
For i = 1 To dailogbox.SelectedItems.Count
With Workbooks.Open(dailogbox.SelectedItems(i)) ' open and reference current workbook
For Each mySheet In .Worksheets ' loop through current workbook worksheets
mySheet.UsedRange.Copy targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Offset(1) ' copy current worksheet "used" range and paste them into target sheet from its column A first empty cell after last not empty one
Next
.Close False ' cloe current workbook, discarding changes
End With
Next
End Sub
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.
So I have a dashboard sheet named "Business Plans" where I have a dropdown in cell A2 that's a dropdown selection of a range called "Facilities" and all dashboard data are driven off of lookups. What I want to do is First create a new workbook than a new tab for each dropdown selection with the tab in the same format but the data pasted as values. I attempted the following code that I created to save every dropdown selection as PDF but I have been unsuccessful. Any insight on how I can get this code working will be great.
Sub Worksheet_Generator()
Dim cell As Range
Dim wsSummary As Worksheet
Dim counter As Long
Set wsSummary = Sheets("Business Plans")
For Each cell In Worksheets("dd").Range("$C3:$C75")
If cell.Value = "" Then
counter = counter + 1
Application.StatusBar = "Processing file: " & counter & "/1042"
Else
counter = counter + 1
Application.StatusBar = "Processing file: " & counter & "/1042"
With wsSummary
.Range("$A$2").Value = cell.Value
ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Copy
With ActiveSheet.UsedRange
.Value = .Value
End With
End With
End If
Next cell
Set wsSummary = Nothing
End Sub
I think you are looking for something like the below (adapted from copying-dynamic-rows-into-new-workbook-and-save-it).
Option Explicit
Sub grabber()
Dim thisWb As Workbook: Set thisWb = ThisWorkbook
Dim thisWs As Worksheet: Set thisWs = thisWb.Worksheets("dd") 'replace with relevant name
Dim newBook As Workbook
Dim newws As Worksheet
Dim pathToNewWb As String
Dim uKeys
Dim currentPath, columnWithKey, numCols, numRows, uKey, dataStartRow, columnKeyName
'nobody likes flickering screens
Application.ScreenUpdating = False
'remove any filter applied to the data
thisWs.AutoFilterMode = False
'get the path of the workbook folder
currentPath = Application.ThisWorkbook.Path
'Set the stage
'###Hardcode###
columnKeyName = "Facility" 'name of the column with the facility values
dataStartRow = 4 'this is a pure guess, correct as relevenat. Use the header row index
pathToNewWb = currentPath & "/Business Plans.xlsx" ' where to put the new excel, if you want a saveas prompt you should google "Application.FileDialog(msoFileDialogSaveAs)"
uKeys = Range("Facilities").Value
'###Hardcode End###
columnWithKey = thisWs.Range(dataStartRow & ":" & dataStartRow).Find(what:=columnKeyName, LookIn:=xlValues).Column
numCols = thisWs.UsedRange.Columns.Count
'extract the index of the last used row in the worksheet
numRows = thisWs.UsedRange.Rows.Count
'create the new workbook
Set newBook = Workbooks.Add
'loop the facilities, and do the work
For Each uKey In uKeys
'Filter the keys column for a unique key
thisWs.Range(thisWs.Cells(dataStartRow, 1), thisWs.Cells(numRows, numCols)).AutoFilter field:=columnWithKey, Criteria1:=uKey
'copy the sheet
thisWs.UsedRange.Copy
'Create a new ws for the facility, and paste as values
Set newws = newBook.Worksheets.Add
With newws
.Name = uKey 'I assume the name of the facility is the relevant sheet name
.Range("A1").PasteSpecial xlPasteValues
End With
'remove autofilter (paranoid parrot)
thisWs.AutoFilterMode = False
Next uKey
'save the new workbook
newBook.SaveAs pathToNewWb
newBook.Close
End Sub
EDIT:
As I have not seen your data, I would not be surprised if it requires some revision.
First I try to "frame" the range of the worksheet "dd" that contains the data (the ###Hardcode### bit), define the path for the output, and identify the column that can be filtered for the values corresponding to the named range "Facilities".
I retrieve the values of the named range "Facilities" (into uKeys), and create the output workbook (newBook). Then we go through each value (uKey) from the uKeys in the for loop. Within the loop, I apply an autofilter for the uKey. The filtration is followed by creation of a sheet (newWs) in newBook, and a copy paste of the filtered worksheet "dd" into newWs. we then turn off the autofilter, and the worksheet "dd" is returned to its unfiltered state.
At the end we save newBook to the desired location, and close it.
Trying to complete a VBA routine for the first time.
The goal is :
Use a vertical range of cell that have different names in each cell to create multiples worksheets in one new workbook.
Here's what i got until now :
Sub AddWorksheet()
Dim plage As Range
Dim i As Integer
Dim titre As String
Dim wb As Workbook
Set plage = Range("E6:E24")
Set wb = Workbooks.Add("New Workbook")
For i = 1 To plage.Height
If plage.Cells(i).Value <> "" Then
titre = plage.Cells(i).Value
ActiveWorkbook.Sheets("FeuilleTemplate").Copy After:=wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Activate
ActiveSheet.Name = titre
End If
Next i
End Sub
Until now the following line is giving me a hard time :
Set wb = Workbooks.add("New Worbook")
The error message is : Error execution '1004' :
The method 'dd' of the object 'Workbooks' has failed.
I'm having a hard time reading and finding the info too for how the methods and class works
I'm use to java.
Thanx for those who gona take time to help me thru this
I think we cannot add a workbook with a specified name as it is not yet saved. So just add workbook do all the operations and in the end save it with the desired name.
Sub AddWorksheet()
Application.DefaultSaveFormat = xlOpenXMLWorkbook
Dim plage As Range
Dim i As Integer
Dim OldBook As Workbook, NewBook As Workbook 'declare both workbooks
Set OldBook = ActiveWorkbook
spath = ThisWorkbook.Path
Set plage = OldBook.Sheets("Sheet Names").Range("E6:E24") 'Assuming that sheet names are in range E6:E24 in "Sheet Names" sheet in old workbook
Set NewBook = Workbooks.Add 'adding new workbook so as to copy the template sheet but this workbook is not saved yet
For i = 1 To plage.Height
If plage.Cells(i).Value <> "" Then 'for each non blank cell in range
OldBook.Sheets("FeuilleTemplate").Copy After:=NewBook.Sheets(NewBook.Sheets.Count) 'Copy "FeuilleTemplate" sheet in workbook after last sheet
NewBook.Sheets("FeuilleTemplate").Name = plage.Cells(i).Value 'Rename the sheet to the desired names from range E6:E24 in "Sheet Names" sheet in old workbook
End If
Next i
With NewBook
.SaveAs Filename:=spath & "\" & "New Workbook with Templates"
.Close SaveChanges:=True
End With
End Sub
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