The following issue occured to me. I use MS Excel 2013.
With the macro below I tried to find those accounts (which meets the criteria "In scope", e.g. account 12345678), to copy them, to search in the same folder (where ThisWorkbook is), to find another excel file which has as name the number of account (e.g. "12345678.xlsx") and to open it.
After the proposed corrections below, my macro finds and opens the desired file. But now the problem is that no actions can be performed on it: copy, paste, etc.
Could you please help on this?
Sub FileFinder()
'Excel variables:
Dim RngS As Excel.Range
Dim wbResults As Workbook
'Go to the column with specific text
Worksheets("Accounts source data").Activate
X = 3
Y = 25
While Not IsEmpty(Sheets("Accounts source data").Cells(X, Y))
Sheets("Accounts source data").Cells(X, Y).Select
If ActiveCell = "In scope" Then
Sheets("Accounts source data").Cells(X, Y - 22).Select
'Copy the account in scope
Set RngS = Selection
Selection.Copy
'Search, in same directory where the file is located, the file with that account (file comes with account number as name)
sDir = Dir$(ThisWorkbook.Path & "\" & RngS & ".xlsx", vbNormal)
Set oWB = Workbooks.Open(ThisWorkbook.Path & "\" & sDir)
'Here is where my error occurs
'[Run-time error 5: Invalid procedure call or argument]
Sheet2.Cells("B27:B30").Copy
oWB.Close
End If
X = X + 1
Wend
End Sub
Try the code below, I have my explanation and questions for you in the code (as commnets):
Option Explicit
Sub FileFinder()
' Excel variables:
Dim wbResults As Workbook
Dim oWB As Workbook
Dim Sht As Worksheet
Dim RngS As Range
Dim sDir As String
Dim LastRow As Long
Dim i As Long, Col As Long
Col = 25
' set ThisWorkbook object
Set wbResults = ThisWorkbook
' set the worksheet object
Set Sht = Worksheets("Accounts source data")
With Sht
' find last row with data in Column "Y" (Col = 25)
LastRow = .Cells(.Rows.Count, 25).End(xlUp).Row
For i = 3 To LastRow
If .Cells(i, Col) = "In scope" Then
' Set the range directly, no need to use `Select` and `Selection`
Set RngS = .Cells(i, Col).Offset(, -22)
' Search, in same directory where the file is located, the file with that account (file comes with account number as name)
sDir = Dir$(ThisWorkbook.Path & "\" & RngS.Value & ".xlsx", vbNormal)
Set oWB = Workbooks.Open(ThisWorkbook.Path & "\" & sDir)
oWB.Worksheets("Report").Range("B27:B30").Copy
' *** Paste in ThisWorkbook, in my exmaple "Sheet2" <-- modify to your needs
wbResults.Worksheets("Sheet2").Range("C1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
oWB.Close SaveChanges:=False
' sDir = Dir$
' clear objects
Set RngS = Nothing
Set oWB = Nothing
End If
Next i
End With
End Sub
Related
I'm attempting to write a program to loop through a directory of excel files and copy a range into a "Master Workbook". When I run the program I am prompted with "Code execution has been interrupted". If I select continue the code will successfully run but then a "run-time error '-2147221080' Automation error" appears.
The line that causes the error is:
Set ws = wb.Worksheets("Project Log")
My question is, why is this line causing the error and or is there a way to bypass the error prompt so that my code will successfully run?
Sub FileCompiler()
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim ws as Worksheet
'set workbook in which data will be copied to
Set Masterwb = ActiveWorkbook
'declare path
'folderPath = "C:MyPath\"
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
'compile directory data to master spreadsheet
Filename = Dir(folderPath & "*.xls*")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
Set ws = wb.Worksheets("Project Log")
ws.Range(ws.Cells(2, "C"), ws.Cells(2, "C")).Copy
Masterwb.Worksheets("Staging").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
ws.Range(ws.Cells(7, "A"), ws.Cells(Rows.Count, "K").End(xlUp)).Copy
Masterwb.Worksheets("Staging").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
wb.Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
Dim Finfo As String
Dim FilterIndex As Long
Dim Title As String
Dim CopyBook As Workbook
Dim CopySheet As Worksheet
Dim ForecastFileName As Variant
Dim MasterSheet AS Worksheet
Set MasterSheet = ThisWorkbook.Worksheets("Yoursheetname")
'now you can always use master sheet after you set copybook
'Set up file filter
Finfo = "Excel Files (*.xls*),*.xls*"
'Set filter index to Excel Files by default in case more are added
FilterIndex = 1
' set Caption for dialogue box
Title = "Hey there!, select a file"
'get the Forecast Filename
ForecastFileName = Application.GetOpenFilename(Finfo, FilterIndex, Title)
'Change this according to what you need for workbook and worksheet names
Workbooks.Open (ForecastFileName)
Set CopyBook = ActiveWorkbook
Set CopySheet = CopyBook.Worksheets(1)
'Do your code, remember to close
CopyBook.Close savechanges:=False 'Not needed now
You might want to check for the ForecastFileName being False, that is when the users x's out, you will also want to do a little validation the wb sheet is in the right format by checking column headers ect or you will wind up crashing.
I have the following macro to filter specific data out of my directory with employee hours files and place it into my zmaster file. However, I need various master documents for various projects (EG. change name to: "project 300000"). When I change my master file name from zmaster to anything else, my macro cannot find the appropriate file, obviously.
Is there a way to change my macro in such a way that zmaster.xlsm is automatically replaced in my macro by the current file name?
Option Explicit
Sub CopyToMasterFile()
Dim MasterWB As Workbook
Dim MasterSht As Worksheet
Dim MasterWBShtLstRw As Long
Dim FolderPath As String
Dim TempFile
Dim CurrentWB As Workbook
Dim CurrentWBSht As Worksheet
Dim CurrentShtLstRw As Long
Dim CurrentShtRowRef As Long
Dim CopyRange As Range
Dim ProjectNumber As String
FolderPath = "C:\test\"
TempFile = Dir(FolderPath)
Dim WkBk As Workbook
Dim WkBkIsOpen As Boolean
'Check if zmaster is open already
For Each WkBk In Workbooks
If WkBk.Name = "zmaster.xlsm" Then WkBkIsOpen = True
Next WkBk
If WkBkIsOpen Then
Set MasterWB = Workbooks("zmaster.xlsm")
Set MasterSht = MasterWB.Sheets("Sheet1")
Else
Set MasterWB = Workbooks.Open(FolderPath & "zmaster.xlsm")
Set MasterSht = MasterWB.Sheets("Sheet1")
End If
ProjectNumber = MasterSht.Cells(1, 1).Value
Do While Len(TempFile) > 0
'Checking that the file is not the master and that it is a xlsx
If Not TempFile = "zmaster.xlsm" And InStr(1, TempFile, "xlsx", vbTextCompare) Then
Set CopyRange = Nothing
'Note this is the last used Row, next empty row will be this plus 1
With MasterSht
MasterWBShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set CurrentWB = Workbooks.Open(FolderPath & TempFile)
Set CurrentWBSht = CurrentWB.Sheets("Sheet1")
With CurrentWBSht
CurrentShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For CurrentShtRowRef = 1 To CurrentShtLstRw
If CurrentWBSht.Cells(CurrentShtRowRef, "A").Value = ProjectNumber Then
'This is set to copy from Column A to Column L as per the question
If CopyRange Is Nothing Then
'If there is nothing in Copy range then union wont work
'so first row of the work sheet needs to set the initial copyrange
Set CopyRange = CurrentWBSht.Range("A" & CurrentShtRowRef & _
":L" & CurrentShtRowRef)
Else
'Union is quicker to be able to copy from the sheet once
Set CopyRange = Union(CopyRange, _
CurrentWBSht.Range("A" & CurrentShtRowRef & _
":L" & CurrentShtRowRef))
End If ' ending If CopyRange Is Nothing ....
End If ' ending If CurrentWBSht.Cells....
Next CurrentShtRowRef
CopyRange.Select
'add 1 to the master file last row to be the next open row
CopyRange.Copy MasterSht.Cells(MasterWBShtLstRw + 1, 1)
CurrentWB.Close savechanges:=False
End If 'ending If Not TempFile = "zmaster.xlsx" And ....
TempFile = Dir
Loop
ActiveSheet.Range("A1:L200").RemoveDuplicates Columns:=Array(1, 2, 4, 8, 9, 10, 11, 12), Header:=xlYes
End Sub
One way to escape from hard coded workbook names is to use ActiveWorkbook or ThisWorkbook objects - they both return instance of Workbook object.
ThisWorkbook
Returns a Workbook object that represents the workbook
where the current macro code is running. Read-only.
ActiveWorkbook
Returns a Workbook object that represents the workbook in the active
window (the window on top). Read-only. Returns Nothing if there are no
windows open or if either the Info window or the Clipboard window is
the active window.
Then you can get the name of the workbook with Name property of the returned Workbook object.
Another way could be if you pass such a data as parameter to your functions.
For example:
Sub CopyToMasterFile(wbName as String, sheetName as String)
In this variant if you call your Sub from another macro code, you can pass whatever you want to use - this ways you can escape the hard coded stuff in your functions.
This is also valid for the Worksheet objects - have a look on the ActiveSheet
The problem: I am trying to copy data from one workbook to another.
Lets say I have a workbook (called DATA) with several worksheets filled with data. Each column of data has a unique heading (all headings on the same row).
On the other hand I have another workbook (called REPORT) with one worksheet that contains only the heading of the data (in one row). They are not in the same order as in DATA workbook. For example I have 3 headings in REPORT worksheet that can be found in different worksheets in DATA workbook.
I need to loop through all the worksheets in the DATA workbook and copy paste the whole column to the REPORT worksheet when the same heading is found.
This image may help to understand. Explanation
My first attempt:
Dim MyFile As String
Dim ws As Worksheet
''Workbook that contains one worksheet with all the headings ONLY NO DATA
Dim TargetWS As Worksheet
Set TargetWS = ActiveSheet
Dim TargetHeader As Range
''Location of Headers I want to search for in source file
Set TargetHeader = TargetWS.Range("A1:G1")
''Source workbook that contains multiple sheets with data and headings _
not in same order as target file
Dim SourceWB As Workbook
Set SourceWB = Workbooks("Source.xlsx")
Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
Dim SourceCell As Range
''Stores the col of the found value and the last row of data in that col
Dim RealLastRow As Long
Dim SourceCol As Integer
''Looping through all worksheets in source file, looking for the heading I want _
then copying that whole column to the target file I have
For Each ws In SourceWB.Sheets
ws.Activate
For Each Cell In TargetHeader
If Cell.Value <> "" Then
Set SourceCell = Rows(SourceHeaderRow).Find _
(Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not SourceCell Is Nothing Then
SourceCol = SourceCell.Column
RealLastRow = Columns(SourceCol).Find("*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If RealLastRow > SourceHeaderRow Then
Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
SourceCol)).Copy
TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
End If
End If
End If
Next
Next
I am getting an error of Application-defined or object-defined error Run-time 1004. Is there something wrong with my logic/syntax..?
Please help I am so bad in VBA.
Thanks in advance!
your last edited code works
but you're making unnecessary checks and I'd suggest you to loop through each sheet header and check if it exists in TargetHeader range to possibly subsequently copy its column to SourceWB
furthermore you may want to have your code more robust and check for actual wanted workbooks/worksheets existence before attempting to set variables to them
like follows:
Option Explicit
Sub main()
Dim SourceWB As Workbook
Dim ws As Worksheet, TargetWS As Worksheet
Dim TargetHeader As Range, cell As Range, SourceCell As Range
Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
''Source workbook that contains multiple sheets with data and headings _
not in same order as target file
Set SourceWB = GetWb("Source.xlsx")
If SourceWB Is Nothing Then Exit Sub
''Workbook that contains one worksheet with all the headings ONLY NO DATA
'Set TargetWS = ActiveSheet
Set TargetWS = GetWs("REPORT") 'it will get the first worksheet (if any) in "REPORT" workbook (if open)
If TargetWS Is Nothing Then Exit Sub
''Location of Headers I want to search for in source file
Set TargetHeader = TargetWS.Range("A1:G1")
''Looping through all worksheets in source file, looking for the heading I want _
then copying that whole column to the target file I have
For Each ws In SourceWB.Sheets
For Each cell In ws.Rows(SourceHeaderRow).SpecialCells(xlCellTypeConstants, xlTextValues)
Set SourceCell = TargetHeader.Find(cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not SourceCell Is Nothing Then
Range(cell.Offset(1), ws.Cells(ws.Rows.Count, cell.Column).End(xlUp)).Copy
SourceCell.Offset(1).PasteSpecial xlPasteValues
End If
Next
Next
End Sub
Function GetWb(wbName As String) As Workbook
On Error Resume Next
Set GetWb = Workbooks(wbName)
On Error GoTo 0
If GetWb Is Nothing Then MsgBox "Sorry, the workbook '" & wbName & "' isn't open" & vbCrLf & vbCrLf & "Please open it and run the macro again"
End Function
Function GetWs(wbName As String, Optional wsName As Variant) As Worksheet
Dim wb As Workbook
Dim ws As Worksheet
Set wb = GetWb(wbName)
If wb Is Nothing Then Exit Function
On Error Resume Next
If IsMissing(wsName) Then
Set GetWs = wb.Worksheets(1) ' if no ws name passed then get the first one
Else
Set GetWs = wb.Worksheets(wsName)
End If
On Error GoTo 0
If GetWs Is Nothing Then MsgBox "Sorry, the worksheet '" & wsName & "0 isn't in '" & wb.Name & "'" & vbCrLf & vbCrLf & "Please open a valid workbook and run the macro again"
End Function
I'm using a VBA code to cycle through excel files in a directory and pull information from one worksheet and paste into a newly created worksheet. I'm also naming my new worksheets (in my destination file) by the name in one of the cells in the source file.
My code works for the first loop but fails/stops in the second loop (VBA points to an error in the Dest.Sheets.Add(After:=Dest.Sheets(Dest.Sheets.Count)).Name = Sheetname line. I need to loop through 75 of these files and I'm unsure of what's going on because it works correctly for the first file.
Thanks so much for the help!
Sub AddSummaryTables()
Dim Spath, Filename, Sheetname As String
Dim Source, Dest As Workbook
Dim WS As Worksheet
Set Dest = ThisWorkbook
Spath = InputBox("Enter File Source Path") & "\"
Filename = Dir(Spath & "*.xls*")
Do While Filename <> ""
Set Source = Workbooks.Open(Spath & Filename)
Sheetname = Source.Sheets("Summary").Range("B2").Text
MsgBox Sheetname
Dest.Sheets.Add(After:=Dest.Sheets(Dest.Sheets.Count)).Name = Sheetname
Source.Sheets("Summary").Range("A1:R150").Copy
Dest.Worksheets(Sheetname).Range("A1").PasteSpecial xlPasteValues
Dest.Worksheets(Sheetname).Range("A1").PasteSpecial xlPasteFormats
Dest.Worksheets(Sheetname).Range("A1:R150").WrapText = False
Dest.Worksheets(Sheetname).Rows.AutoFit
Dest.Worksheets(Sheetname).Columns.AutoFit
Source.Close SaveChanges:=False
Dest.Save
Filename = Dir()
Loop
End Sub
following Comintern's and Wyatt's suggestion you could try like follows
Option Explicit
Sub AddSummaryTables()
Dim sPath As String, fileName As String
Dim sourceWb As Workbook, destWb As Workbook
Dim sourceWs As Worksheet, destWs As Worksheet
Set destWb = ThisWorkbook
sPath = InputBox("Enter File Source Path") & "\"
fileName = Dir(sPath & "*.xls*")
Do While fileName <> ""
Set sourceWb = Workbooks.Open(sPath & fileName)
Set sourceWs = GetWorksheet(sourceWb, "Summary")
If Not sourceWs Is Nothing Then
Set destWs = SetWorksheet(destWb, sourceWs.Range("B2").Text)
sourceWs.Range("A1:R150").Copy
With destWs
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").PasteSpecial xlPasteFormats
.UsedRange.WrapText = False
.Rows.AutoFit
.Columns.AutoFit
End With
sourceWb.Close SaveChanges:=False
destWb.Save
End If
fileName = Dir()
Loop
End Sub
Function GetWorksheet(wb As Workbook, sheetName As String) As Worksheet
On Error Resume Next
Set GetWorksheet = wb.Worksheets(sheetName)
On Error GoTo 0
End Function
Function SetWorksheet(wb As Workbook, sheetName As String) As Worksheet
Dim i As Integer
Do While Not GetWorksheet(wb, sheetName & IIf(i = 0, "", "-" & i)) Is Nothing
i = i + 1
Loop
With wb
.Worksheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = sheetName & IIf(i = 0, "", "-" & Format(i, "000"))
Set SetWorksheet = .ActiveSheet
End With
End Function
where you make sure that
any opened workbook has a "Summary" worksheet
you name worksheets in your destination workbook such as not to have duplicates: if you happen to deal with say three worksheets named "Sheet5" then your destination workbook will have added worksheets "Sheet5", "Sheet5-001" and "Sheet5-002".
You're issue may be that when you are adding the sheet from the second workbook, it has the same name as the sheet from the first workbook. You could check if the sheet exists and add a number to it. The post below might help.
Test or check if sheet exists
I have a code see below to import data from different workbooks inside one folder. I try it and it works perfectly however I was wondering if someone could help me to improve it.
I explain: "zmaster.xlms" workbook is the one where all data are past in sheet one. In this same workbook in sheet2 i have a table like this:
Where the column "Excel Column code" is where the data should be past (in the "zmaster.xlms") and "Form Cell Code" correspond to the cells which should be copy from every workbooks (which are in the same file in my desktop).
Question: How To say to the macro to look at the table and copy the cell K26 and past it in the columnA of the zmaster file and loop until the end of the table?
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\Desktop\New folder\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
' Range("A1:D1").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
MyFile = Dir
Loop
End Sub
Thank you in advance for your help!
All you need to do is to loop through the cells in sheet 2 (zmaster.xlsm). Have a look at example code. Please, read comments.
[EDIT]
Code has been updated!
Option Explicit
'assuming that:
'- "Excel Column Code" is in column A
'- "Form Cell Code" is in column B
'in zmaster.xlsm!Sheet2
Sub UpdateData()
Dim sFile As String, sPath As String
Dim srcWbk As Workbook, dstWbk As Workbook
Dim srcWsh As Worksheet, dstWsh As Worksheet, infoWsh As Worksheet
Dim i As Long, j As Long, k As Long
On Error GoTo Err_UpdateData
Set dstWbk = ThisWorkbook
Set dstWsh = dstWbk.Worksheets("Sheet1")
Set infoWsh = dstWbk.Worksheets("Sheet2")
sPath = "C:\Desktop\New folder\"
sFile = Dir(sPath)
Do While Len(sFile) > 0
If sFile = "zmaster.xlsm" Then
GoTo SkipNext
End If
Set srcWbk = Workbooks.Open(sPath & sFile)
Set srcWsh = srcWbk.Worksheets(1)
i = 2
'loop through the information about copy-paste method
Do While infoWsh.Range("A" & i) <> ""
'get first empty row, use "Excel Column Code" to get column name
j = GetFirstEmpty(dstWsh, infoWsh.Range("A" & i))
'copy data from source sheet to the destination sheet
'use "Form Cell Code" to define destination cell
srcWsh.Range(infoWsh.Range("B" & i)).Copy dstWsh.Range(infoWsh.Range("A" & i) & j)
i = i + 1
Loop
srcwbk.Close SaveChanges:=False
SkipNext:
sFile = Dir
Loop
Exit_UpdateData:
On Error Resume Next
Set srcWsh = Nothing
Set dstWsh = Nothing
Set srcWbk = Nothing
Set dstWbk = Nothing
Exit Sub
Err_UpdateData:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_UpdateData
End Sub
'returns first empty row in a destination sheet based on column name
Function GetFirstEmpty(ByVal wsh As Worksheet, Optional ByVal sCol As String = "A") As Long
GetFirstEmpty = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function
At the moment you code
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
is simply copying columns A to D of the first row of data in the source worksheet to a new row in the destination worksheet.
I'm assuming that you still want to create a new single row, but that you want the table on sheet2 to define which cells are put into which column of the new row.
you need to write something like this (which is untested):
Sub YourCode()
Dim MyFile As String
Dim erow
Dim Filepath As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsDestination As Worksheet
Dim rngMapping As Range
Dim DestinationRow As Long
Dim cell As Range
Filepath = "C:\Desktop\New folder\"
MyFile = Dir(Filepath)
Set wsDestination = ActiveWorkbook.Sheet1
' Named range "MappingTableFirstColumn" is defined as having the first column in the sheet2 table and all the rows of the table.
Set rngMapping = ActiveWorkbook.Names("MappingTable").RefersToRange
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Set wbSource = Workbooks.Open(Filepath & MyFile)
Set wsSource = wbSource.Sheets("Sheet1")
DestinationRow = wsDestination.Cells(wsDestination.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For Each cell In rngMapping
wsDestination.Range(cell.Value & DestinationRow) = wsSource.Range(cell.Offset(0, 1)).Value
Next cell
MyFile = Dir
Loop
ActiveWorkbook.Close
End Sub