I have this code that pulls data from 4 separate workbooks and paste them into the next empty section in a template workbook (FRF_Data_Macro_Insert_Test). This works perfectly but i have one issue, I need it to be able to paste in the active workbook and not to be dependent on the file name. Because this is a template and therefore read only, it prompts you to save as a different file name upon opening. I told the people using this to just cancel the first save as window and just save as when all done pulling data but they keep saving as before they pull data making it not work because its looking for FRF_Data_Macro_Insert_Test filename. Any help is much appreciated!
Thanks
Code:
Sub DataTransfer()
Const FPATH As String = "C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\"
Application.ScreenUpdating = False
Dim wb As Workbook
Dim shtAlpha As Worksheet 'Template
Dim locs, loc
Dim rngDest As Range
locs = Array("Location1.xls", "Location2.xls", _
"Location3.xls", "Location4.xls")
Set shtAlpha = Workbooks("FRF_Data_Sheet_Template.xlsm").Sheets("DataInput")
'set the first data block destination
Set rngDest = shtAlpha.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(5, 3)
For Each loc In locs
Set wb = Workbooks.Open(FileName:=FPATH & loc, ReadOnly:=True)
rngDest.Value = wb.Sheets("Data").Range("I3:K7").Value
wb.Close False
Set rngDest = rngDest.Offset(0, 3) 'move over to the right 3 cols
Next loc
Application.ScreenUpdating = True
End Sub
As your macro is in the workbook you want to reference, you can simply use ThisWorkbook:
Sub DataTransfer()
Const FPATH As String = "C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\"
Application.ScreenUpdating = False
Dim wb As Workbook
Dim shtAlpha As Worksheet 'Template
Dim locs, loc
Dim rngDest As Range
locs = Array("Location1.xls", "Location2.xls", _
"Location3.xls", "Location4.xls")
Set shtAlpha = ThisWorkbook.Sheets("DataInput")
'set the first data block destination
Set rngDest = shtAlpha.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(5, 3)
For Each loc In locs
Set wb = Workbooks.Open(Filename:=FPATH & loc, ReadOnly:=True)
rngDest.Value = wb.Sheets("Data").Range("I3:K7").Value
wb.Close False
Set rngDest = rngDest.Offset(0, 3) 'move over to the right 3 cols
Next loc
Application.ScreenUpdating = True
End Sub
I would post this as just a comment, but it won't let me.
I'm not sure if i'm following what you're asking right, but if it's a matter of just saving a separate copy with a different name automatically, then itt would be Workbooks("FRF_Data_Sheet_Template.xlsm").SaveCopyAs
Related
I have built this code which import data from a workbook and paste it to another one. The original workbook is composed by hundred of sheets (one sheet for each country, identified by the ISO 2 digit code: AE, AL, AM, AR etc...). The macro is opening each one of these sheets, copying the same cell, and printing all these cells in a new workbook.
The problem is that if, for example, the sheet F(AM) doesn't exists, the macro stops. I would like to make sure that if a sheet doesn't exist, the macro continues with all the other sheets (namely F(AR), F(AT), F(AU)) till the end.
Someone has any suggestion?
Many thanks in advance!
Sub ImportData()
Dim Wb1 As Workbook
Dim MainBook As Workbook
Dim Path As String
Dim SheetName As String
'Specify input data
Path = Worksheets("Input").Range("C6").Value
'Decide in which target sheet print the results
SheetName = "Data"
'From which sheets you need to take the data?
OriginSheet145 = "F(AE)"
OriginSheet146 = "F(AL)"
OriginSheet147 = "F(AM)"
OriginSheet148 = "F(AR)"
OriginSheet149 = "F(AT)"
OriginSheet150 = "F(AU)"
'Set the origin workbook
Set Wb1 = Workbooks.Open(Path & "_20171231.xlsx")
'Set the target workbook
Set MainBook = ThisWorkbook
'Vlookup to identify the correct data point
Wb1.Sheets(OriginSheet145).Range("N25").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
Wb1.Sheets(OriginSheet146).Range("N26").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
Wb1.Sheets(OriginSheet147).Range("N27").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
Wb1.Sheets(OriginSheet148).Range("N28").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
Wb1.Sheets(OriginSheet149).Range("N29").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
Wb1.Sheets(OriginSheet150).Range("N30").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
'Copy the data point and paste in the target sheet
Wb1.Sheets(OriginSheet145).Range("N25").Copy
MainBook.Sheets(SheetName).Range("AW5").PasteSpecial xlPasteValues
Wb1.Sheets(OriginSheet146).Range("N26").Copy
MainBook.Sheets(SheetName).Range("AW6").PasteSpecial xlPasteValues
Wb1.Sheets(OriginSheet147).Range("N27").Copy
MainBook.Sheets(SheetName).Range("AW7").PasteSpecial xlPasteValues
Wb1.Sheets(OriginSheet148).Range("N28").Copy
MainBook.Sheets(SheetName).Range("AW8").PasteSpecial xlPasteValues
Wb1.Sheets(OriginSheet149).Range("N29").Copy
MainBook.Sheets(SheetName).Range("AW9").PasteSpecial xlPasteValues
Wb1.Sheets(OriginSheet150).Range("N30").Copy
MainBook.Save
Wb1.Close savechanges:=False
MsgBox "Data: imported!"
End Sub
This function returns TRUE or FALSE, indicating whether a worksheet named in string wsName exists in workbook object
Function wsExists(wb As Workbook, wsName As String) As Boolean
Dim ws: For Each ws In wb.Sheets
wsExists = (wsName = ws.Name): If wsExists Then Exit For
Next ws
End Function
Us an IF statement to skip the applicable code if the worksheet does not exist.
Edit:
I can tell that you put a lot of work into your code, which is awesome, so don't take it the wrong way when I say it gave me anxiety so I had to simplify it. ...there are a lot of unneeded steps.
I do believe the "right way" is "whatever way works", so kudo's on getting this far. There's a steep learning curve in programming, so I figured I'd offer an alternate code block to replace yours. (The Option Explicit goes at the very top of the module, and will "force" you to properly declare/handle variables, objects, etc.)
Without seeing your data I can't guarantee this will work - in fact it very likely a cell reference wrong somewhere that you'll have to try to figure out - if you choose to use this at all.
Option Explicit
Sub ImportData()
Const SheetName = "Data" 'destination sheet name
Const sourceFile = "_20171231.xlsx" 'source filename for some reason
Dim wbSrc As Workbook, wbDest As Workbook, sht As Variant
Dim stPath As String, arrSourceSht() As Variant, inRow As Long
Set wbDest = ThisWorkbook 'dest wb object
stPath = Worksheets("Input").Range("C6").Value 'source wb stPath
'create array of source sheet names "146-150":
arrSourceSht = Array("F(AE)", "F(AL)", "F(AM)", "F(AR)", "F(AT)", "F(AU)")
Set wbSrc = Workbooks.Open(stPath & sourceFile) 'open source wb
With wbSrc
'VLookup to identify the correct data point
inRow = 5 'current input row
For Each sht In arrSourceSht
If wsExists(wbSrc, CStr(sht)) Then
wbDest.Sheets(sht).Range("AW" & inRow) = Application._
WorksheetFunction.VLookup("010", Range(.Sheets(sht).Range("N" & _
20 + inRow).Offset(-10), .Sheets(sht).Range("N" & 20 + inRow).Offset(-7)), 2, False)
End If
inRow = inRow + 1 'new input row
Next sht
wbDest.Save 'save dest
.Close savechanges:=False 'don't save source
End With
MsgBox "Data: imported!"
End Sub
Function wsExists(wb As Workbook, wsName As String) As Boolean
Dim ws: For Each ws In wb.Sheets
wsExists = (wsName = ws.Name): If wsExists Then Exit For
Next ws
End Function
Let me know if you have any questions, I can walk you through how it works if you like. (I'm on here at least once a day.)
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 keep having this issue of VBA either not having an object for the new sheet I want to merge, or having the subscript out of range issue come up. None of the things I tried ended up working.
Private Sub MergeButton_Click()
Dim filename As Variant
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim lastUsedRow As Range
Dim j As Integer
On Error GoTo ErrMsg
Application.ScreenUpdating = False
Set thisSheet = ThisWorkbook.ActiveSheet
MsgBox "Reached method"
'j is for the sheet number which needs to be created in 2,3,5,12,16
For Each Sheet In ActiveWorkbook.Sheets
For i = 0 To FilesListBox.ListCount - 1
filename = FilesListBox.List(i, 0)
'Open the spreadsheet in ReadOnly mode
Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)
'Copy the used range (i.e. cells with data) from the opened spreadsheet
If FirstRowHeadersCheckBox.Value And i > 0 Then 'Only include headers from the first spreadsheet
Dim mr As Integer
mr = wb.ActiveSheet.UsedRange.Rows.Count
wb.ActiveSheet.UsedRange.Offset(3, 0).Resize(mr - 3).Copy
Else
wb.ActiveSheet.UsedRange.Copy
End If
'thisSheet = ThisWorkbook.Worksheets(SheetCurr)
'Paste after the last used cell in the master spreadsheet
If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
Set lastUsedRow = thisSheet.Range("A65536").End(xlUp)
Else
Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp)
End If
'Only offset by 1 if there are current rows with data in them
If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
Set lastUsedRow = lastUsedRow.Offset(1, 0)
End If
lastUsedRow.PasteSpecial
Application.CutCopyMode = False
Next i
This is where I try to add an extra loop that copies the next sheet (which is Sheet12) but it comes up with the Subscript our of range error.
Sheets("Sheet3").Activate
Sheet.Copy After:=ThisWorkbook.Sheets
Next Sheet
It will then move to the next sheet to perform the loop again.
ThisWorkbook.Save
Set wb = Nothing
#If Mac Then
'Do nothing. Closing workbooks fails on Mac for some reason
#Else
'Close the workbooks except this one
Dim file As String
For i = 0 To FilesListBox.ListCount - 1
file = FilesListBox.List(i, 0)
file = Right(file, Len(file) - InStrRev(file, Application.PathSeparator, , 1))
Workbooks(file).Close SaveChanges:=False
Next i
#End If
Application.ScreenUpdating = True
Unload Me
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Any help an this would be great
Your source code is very confusing and I believe you're stumbling because the ActiveWorkbook and ActiveSheet change each time you open a new workbook. It's also not clear why you're copying/merging the data from each worksheet in every opened workbook and then copying Sheet3. You will help yourself by more clearly defining what and where your data is and how you're moving it around.
As an example (that may not solve your problem, because your problem is not clear), look at the code below to see how you can keep the sources and destinations straight within your loops. Modify this example as much as you need in order to match your exact situation.
Sub Merge()
'--- assumes that each sheet in your destination workbook matches a sheet
' in each of the source workbooks, then copies the data from each source
' sheet and merges/appends that source data to the bottom of each
' destination sheet
Dim destWB As Workbook
Dim srcWB As Workbook
Dim destSH As Worksheet
Dim srcSH As Worksheet
Dim srcRange As Range
Dim i As Long
Application.ScreenUpdating = False
Set destWB = ThisWorkbook
For i = 0 To FileListBox.ListCount - 1
Set srcWB = Workbooks.Open(CStr(FileListBox(i, 0)), ReadOnly:=True)
For Each destSH In destWB.Sheets
Set srcSH = srcWB.Sheets(destSH.Name) 'target the same named worksheet
lastdestrow = destSH.Range("A").End(xlUp)
srcSH.UsedRange.Copy destSH.Range(Cells(lastdestrow, 1))
Next destSH
srcWB.Close
Next i
Application.ScreenUpdating = True
End Sub
I need to activate a specific worksheet. The code is meant to create worksheets with a specif name. I need to paste something from a another worksheet into all these newly created worksheets. The code that I'm using is below. But I'm having a hard time activating the newly created worksheet to paste what I want.
Sub octo()
'Dim ws As Worksheet
Dim Ki As Range
Dim ListSh As Range
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\timesheet.xlsx")
With Worksheets("PPE 05-17-15")
Set ListSh = .Range("B4:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
On Error Resume Next
For Each Ki In ListSh
If Len(Trim(Ki.Value)) > 0 Then
If Len(Worksheets(Ki.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Ki.Value
'open template
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\octo_template.xls")
Range("A1:L31").Select
Selection.Copy
Worksheets(Ki.Value).Activate
If ThisWorkbook.Saved = False Then
ThisWorkbook.Save
End If
End If
End If
Next Ki
End Sub
Both Workbooks.Open and Worksheets.Add return references to the opened and added objects, which you can use to directly access and modify them - and in your case, to paste data.
Example:
Dim oSourceSheet As Worksheet
Dim oTargetSheet As Worksheet
Set oSourceSheet = Sheet1 'Set reference to any sheet, Sheet1 in my example
Set oTargetSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
oSourceSheet.Range("A1:L31").Copy
oTargetSheet.Paste
Set oSourceSheet = Nothing
Set oTargetSheet = Nothing
I think that is what you need. As what been mentioned by chris, there is no need Activate or Select. Hope the following code solve your problem.
Option Explicit
Dim MyTemplateWorkbook As Workbook
Dim MyDataWorkbook As Workbook
Dim MyTemplateWorksheet As Worksheet
Dim MyDataWorksheet As Worksheet
Dim MyNewDataWorksheet As Worksheet
Dim CurrentRange As Range
Dim ListRange As Range
Sub AddWSAndGetData()
Set MyTemplateWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyTemplate.xlsx")
Set MyTemplateWorksheet = MyTemplateWorkbook.Sheets("Template")
Set MyDataWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyData1.xlsx")
Set MyDataWorksheet = MyDataWorkbook.Sheets("PPE 05-17-15")
Set ListRange = MyDataWorksheet.Range("B4:B" & MyDataWorksheet.Cells(Rows.Count, "B").End(xlUp).Row)
Application.ScreenUpdating = False
On Error Resume Next
For Each CurrentRange In ListRange
If Len(Trim(CurrentRange.Value)) > 0 Then
If Len(MyDataWorksheet(CurrentRange.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CurrentRange.Value
Set MyNewDataWorksheet = MyDataWorkbook.Sheets(ActiveSheet.Name)
MyNewDataWorksheet.Range("A1:L31").Value = MyTemplateWorksheet.Range("A1:L31").Value
If MyDataWorkbook.Saved = False Then
MyDataWorkbook.Save
End If
End If
End If
Next CurrentRange
MyTemplateWorkbook.Close (False) 'Close the template without saving
End Sub
I'm able to import worksheets successfully to my workbook. But is it possible to just import the columns that I want? The data is really huge and I don't want to have the trouble to go through every part of the cells.
Below are my codes:
Sub ImportSheet()
Dim wb As Workbook
Dim activeWB As Workbook
Dim sheet As Worksheet
Dim FilePath As String
Dim oWS As String
Set activeWB = Application.ActiveWorkbook
FilePath = "C:\Report.xlsx"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = Application.Workbooks.Open(FilePath)
wb.Sheets("Report").Copy After:=activeWB.Sheets(activeWB.Sheets.Count)
activeWB.Activate
wb.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Not sure if I'm breaking protocol here but this is a completely different approach and the option to Add Another Answer was there. This method uses the 'copy to new worksheet' approach which should be easier on limited resources.
Sub ImportSheet()
Dim iWB As Workbook, aWB As Workbook, ws As Worksheet
Dim FilePath As String, v As Long, vCOLs As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FilePath = "C:\Report.xlsx"
vCOLs = Array(1, 13, 6, 18, 4, 2) 'columns to copy in this order
Set aWB = Application.ActiveWorkbook
With aWB
.Sheets.Add after:=.Sheets(.Sheets.Count)
Set ws = .Sheets(.Sheets.Count)
'.name = "Report" 'you can name the new ws but do NOT duplicate
End With
Set iWB = Application.Workbooks.Open(FilePath)
With iWB.Sheets("Report").Cells(1, 1).CurrentRegion
.Cells = .Cells.Value
For v = LBound(vCOLs) To UBound(vCOLs)
.Columns(vCOLs(v)).Copy Destination:=ws.Cells(1, v + 1)
Next v
End With
iWB.Close False
Set iWB = Nothing
Set ws = Nothing
Set aWB = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
My primary concern here is not knowing the layout of the 'Report' worksheet. The boundaries of the .CurrentRegion are dictated by the first fully blank column to the right and the first fully blank row down. A block of data rarely has this but worksheets called Report often do.
You are closing the freshly opened workbook (without saving or warnings) after the copy so I would suggest that you loop through the columns you do not want and delete then prior to the copy. Incorporate this snippet into your existing code
Dim v As Long, vNoCopy As Variant, wb As Workbook
vNoCopy = Array(1, 3, 5, 7) 'should in ascending order (reversed below)
With wb.Sheets("Report")
.Cells = .Cells.Value 'just in case there are referenced formulas involved
For v = UBound(vNoCopy) To LBound(vNoCopy) Step -1
.Columns(vNoCopy(v)).EntireColumn.Delete
Next v
wb.Sheets("Report").Copy After:=activeWB.Sheets(activeWB.Sheets.Count)
End With
wb.Close False
That should remove columns A, C, E & G from the report before copying. Closing without saving should leave the original Report.xlsx unaffected.