I am attempting to extra data from multiple .xlsm in a folder from a specific cell. The idea is to take a folder that has multiple .xlsm files and extract a specific cell into my current workbook.
See code.
Option Explicit
Const FOLDER_PATH = "C:\Users\maxd\OneDrive - Nortek, Inc\Coil Test Data\coils_35_and_36\36\WET\Testing\" 'REMEMBER END BACKSLASH
Sub ImportWorksheets()
'=============================================
'Process all Excel files in specified folder
'=============================================
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
rowTarget = 7
'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
'reset application settings in event of error
'On Error GoTo errHandler
'Application.ScreenUpdating = False
'set up the target worksheet
Set wsTarget = Sheets("Sheet1")
'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xlsm*")
Do Until sFile = ""
'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets("Summary")
'import the data
With wsTarget
.Range("I" & rowTarget).Value = wsSource.Range("B25").Value
'optional source filename in the last column
.Range("N" & rowTarget).Value = sFile
End With
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
'tidy up
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
Actual Results = it does nothing as if there is not a file in the folder.
Expected Results = It will pull the data from cell B25 and insert it to I7 of my current worksheet.
EDIT: When I F8 through the code, it gets to "Set wsSource = wbSource.Worksheets("Summary")" Then I get a runtime error 91
Related
I need to copy a specific row from a worksheet and paste it into another workbook sheet. Thereafter saving the file as a new workbook.
This will need to be done on many workbooks in a folder. For each source workbook copy the row of data, paste it in the master workbook and save the workbook as a new workbook. I require 10 master workbooks as there are 10 source workbooks.
This is where my workbooks reside.
This is a sample of a source workbook file.
I need to copy the data without headers, so row 2. This needs to be done for all files within the folder above. All files have the same layout with just row 2 where the data resides.
The master/destination workbook
The data should be pasted in row 9. This templated workbook resides in a different folder.
Current code increments the rows. I need a new master workbook for each source workbook and thereafter save the master workbook with a source workbook name as a suffix Example "Master workbook-AAAA".xlsx
Option Explicit
Const FOLDER_PATH = "C:\Users\\Desktop\Split Files\" 'REMEMBER END BACKSLASH'
Sub ImportWorksheets()
'Process all Excel files in specified folder'
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
rowTarget = 9
'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
'reset application settings in event of error'
On Error GoTo errHandler
Application.ScreenUpdating = False
'set up the target worksheet'
Set wsTarget = Sheets("DATABASE")
'loop through the Excel files in the folder'
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""
'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets(1)
'import the data'
With wsTarget
.Range("A" & rowTarget).Value = wsSource.Range("A2").Value
.Range("B" & rowTarget).Value = wsSource.Range("B2").Value
.Range("C" & rowTarget).Value = wsSource.Range("C2").Value
.Range("D" & rowTarget).Value = wsSource.Range("D2").Value
.Range("E" & rowTarget).Value = wsSource.Range("E2").Value
.Range("F" & rowTarget).Value = wsSource.Range("F2").Value
.Range("G" & rowTarget).Value = wsSource.Range("G2").Value
.Range("H" & rowTarget).Value = wsSource.Range("H2").Value
.Range("I" & rowTarget).Value = wsSource.Range("I2").Value
End With
'close the source workbook, increment the output row and get the next file'
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
'tidy up'
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
The result is shown below
Update.
I tried a different approach, however the workbook is crashing.
'open template
Const MASTER = "path-to-file\master.xlsx"
Set wbTarget = Workbooks.Open(MASTER)
Set wsTarget = wbTarget.Sheets(1)
wsTarget.Unprotect "password"
Do While sFile <> ""
' read source
Set wbSource = Workbooks.Open(sFolder & sFile, 1, 1) ' update links, readonly
Set wsSource = wbSource.Sheets(1)
' create target
wsTarget.Name = "DATABASE"
wsTarget.Range("A" & ROW_TARGET).Resize(1, 9) = wsSource.Range("A2:I2").Value2
wbTarget.SaveAs "path\to\Master_" & sFile
wbSource.Close False
sFile = Dir
Loop
wsTarget.protect "password"
wbTarget.Close False
I am trying to get a VBA macro to loop through all xls files in a specific folder. The below code works for the most part. However i have 42 files in this folder and the code only loops through about 26 of them. They are all the same file extension.
My thoughts are it either isn't looping through all the files. Or it is looping through all the files however there is an issue with the last row variable and data is being pasted over.
Sub CopyDataBetweenWorkbooks()
Dim wbSource As Workbook
Dim shTarget As Worksheet
Dim shSource As Worksheet
Dim strFilePath As String
Dim strPath As String
Application.ScreenUpdating = False
' Initialize some variables and
' get the folder path that has the files
Set shTarget = ThisWorkbook.Sheets(1)
strPath = GetPath
' Make sure a folder was picked.
If Not strPath = vbNullString Then
' Get all the files from the folder
strfile = Dir$(strPath & "*.xls", vbNormal)
Do While Not strfile = vbNullString
' Open the file and get the source sheet
Set wbSource = Workbooks.Open(strPath & strfile)
Set shSource = wbSource.Sheets("Trend Report")
'Copy the data
Call CopyData(shSource, shTarget)
'Close the workbook and move to the next file.
wbSource.Close False
strfile = Dir$()
Loop
End If
End Sub
' Procedure to copy the data.
Sub CopyData(ByRef shSource As Worksheet, shTarget As Worksheet)
LastRowSource = shSource.Cells(Rows.Count, "B").End(xlUp).Row
Dim strRANGE_ADDRESS As String
Dim lastrow As String
strRANGE_ADDRESS = "B15:H" & LastRowSource - 1
'insert file name
StrFileFullname = ActiveWorkbook.FullName
shSource.Range("H15:H" & LastRowSource).Value = StrFileFullname
'Copy the data.
shSource.Range(strRANGE_ADDRESS).Copy
'Set last row and paste
lastrow = shTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1
shTarget.Range("B" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
' Reset the clipboard.
Application.CutCopyMode = xlCopy
End Sub
' Function to get the folder path
Function GetPath() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.ButtonName = "Select a folder"
.Title = "Folder Picker"
.AllowMultiSelect = False
'Get the folder if the user does not hot cancel
If .Show Then GetPath = .SelectedItems(1) & "\"
End With
End Function
My macro is going through a folder and picking each Excel file and deleting the first tab which is named some_Accounts and then copy pasting data to the master workbook where the worksheet names match.
Getting the following error Method 'Name' of object '_Worksheet' on the following line of code
Set wsDst = wbDst.Worksheets(wsSrc.Name)
I made sure that the worksheet names are equal.
Sub ProjectMacro()
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim lLastRow As Long
Dim LC As Long
Dim s As Worksheet, t As String
Dim i As Long, K As Long
K = Sheets.Count
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wbDst = ThisWorkbook
MyPath = "C:\Users\Adam\Desktop\some files\"
strFilename = Dir(MyPath & "*.xls*", vbNormal)
Do While strFilename <> ""
Set wbSrc = Workbooks.Open(MyPath & strFilename)
'loop through each worksheet in the source file
For Each wsSrc In wbSrc.Worksheets
'Find the corresponding worksheet in the destination with the same
name as the source
For i = K To 1 Step -1
t = Sheets(i).Name
If t = "some_Accounts" Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
End If
Next i
Set wsDst = wbDst.Worksheets(wsSrc.Name)
On Error GoTo 0
If wsDst.Name = wsSrc.Name Then
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
wsSrc.UsedRange.Copy
wsDst.Range("A" & lLastRow).PasteSpecial xlPasteValues
End If
Next wsSrc
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Right now, you are looping through all the Worksheets in wbSrc. When wsSrc is the "some_Accounts" sheet, right after you've deleted it within For i = K to 1... End For, it no longer exists, and thus wsSrc has no Name and will throw an error later on. If you're deleting a sheet, do so before you loop through all the sheets in a workbook.
But since you are closing wbSrc without saving changes, I assume that you don't really need to delete that sheet; you can just skip it as you're looping.
That would look something like this:
For Each wsSrc In wbSrc.Worksheets
If wsSrc.Name <> "some_Accounts" Then
'... copy and pasting code here
End If
Next wsSrc
Note that you can incorporate a WorksheetExists function into your code to make sure that there is a matching sheet in wbDst. That's already been provided in another answer.
Try to put this in your code to see if the worksheet exists:
If worksheetExists(wbDst, wsDst.Name) = true then
MsgBox "Exists!"
else
MsgBox "Does not exist!"
end if
Public Function worksheetExists(ByVal wb As Workbook, ByVal sheetNameStr As String) As Boolean
On Error Resume Next
worksheetExists = (wb.Worksheets(sheetNameStr).Name <> "")
Err.Clear: On Error GoTo 0
End Function
i am trying to replace the current data in my file with the data in any another selected file which have same attributes. i want to replace the data from A1:Q in the current file from any other selected file. I tried writing the code but its showing errors .
Sub newdata()
Set appxl = CreateObject("Excel.application")
Dim myfile As Window
Dim currentSheet As Worksheet
Dim lastRow As Double
Dim sourceFileName As String
'Open Source File.xlsx
With appxl
vFile = Application.GetOpenFilename(Title:="Select File To Be Opened")
If vFile = False Then Exit Sub 'if the user didn't select a file, exit sub
' Set myfile = Workbooks.Open(vFile)
.Visible = False
End With
'Get first sheet data
Set myfile = appxl.Windows(vFile)
myfile.Activate
Set currentSheet = myfile.Sheets(1)
'Past the table in my current Excel file
lastRow = currentSheet.Range("A1").End(xlDown).Row
Sheets("Data retrieval").Range("A1:E" & lastRow) = currentSheet.Range("A1:Q" & lastRow).Value
'Close Source File.xlsx
appxl.Workbooks(vFile).Close
End Sub
This is not the prettiest of codes but it works just as you asked!
Sub newdata()
Dim myfile As Window
Dim currentSheet As Worksheet
Dim lastRow As Double
Dim sourceFileName As String
Dim sourcefileworksheet As String
Dim destinationwb As String
Dim destinationwksheet As String
'set destination worksheet as open workbook when you run macro
destinationwb = ActiveWorkbook.Name
destinationwksheet = ActiveSheet.Name
'Select source file
Dim fNameAndPath As Variant, wb As Workbook
fNameAndPath = Application.GetOpenFilename(Title:="Select File To Be Opened")
' cancel macro if nothing selected
If fNameAndPath = False Then
MsgBox ("Nothing Selected, Macro Cancelled")
Exit Sub
End If
'Open Source File.xlsx
Workbooks.Open (fNameAndPath)
'set source names
sourceFileName = ActiveWorkbook.Name
sourcefileworksheet = ActiveSheet.Name
'Determine last row of source
lastRow = Workbooks(sourceFileName).Worksheets(sourcefileworksheet).Range("A1").End(xlDown).Row
'Past the table in my current Excel file - Note that you should change the range of destination to A1:Q if you want all copied
Workbooks(destinationwb).Worksheets(destinationwksheet).Range("A1:E" & lastRow) = Workbooks(sourceFileName).Worksheets(sourcefileworksheet).Range("A1:Q" & lastRow).Value
'Close Source File.xlsx
Workbooks(sourceFileName).Close
'Confirm complete
MsgBox ("Complete!")
End Sub
I have many excel files, each with just one worksheet, in a folder that contain data from 5 sources. The source is located in Column L. I would like to read through each row of all files and create 5 master worksheets. I think the number of sources should not be limited to just 5 sources, the macro should just read all rows in all files and copy the row to a master worksheet based on the value located in cell L. The Start_Row is 3 for reading and writing. I think I have working code for reading through each file and each worksheet but having problem with reading and writing rows
Sub ParseByDevice()
Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim wbThis As Workbook
Dim ws As Worksheet
Dim Pws As Worksheet 'Parsed Worksheet based on Column L (i, 12)
Dim a As Range
Dim b As Range
Dim rw As Range
Dim cl As Range
Dim MyBook As Workbook
Dim newBook As Workbook
Dim FileNm As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\xml\vac" 'Change as needed
FileName = Dir(Path & "\livevalues*.xls", vbNormal)
'
'ALL FILES IN FOLDER LOOP
'
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
'
'ALL EACH WORKSHEET IN WORKBOOK LOOP
'
'next worksheet in file;
'only expect one worksheet but maybe more in the future
'
For Each ws In Wkb.Worksheets
'
' FOR EACH ROW IN WORKSHEET LOOP
'
rw = 3 'first row after header
For Each rw In ws
MsgBox Wkb.Sheets(ws).row(rw, 12).Value 'this is temporary, just a visual check that things are going well
cl = Wkb.Sheets(ws).row(rw, 12).Value
Wkb.Sheets(ws).row(rw, 12).Copy Pws.Sheets(cl)
Next rw 'next row in worksheet
Next ws 'next worksheet in file;
Wkb.Close False
FileName = Dir()
Loop 'Do next file in folder
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
One approach:
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\xml\vac" 'Change as needed
FileName = Dir(Path & "\livevalues*.xls", vbNormal)
Set MyBook = ThisWorkbook
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
For Each ws In Wkb.Worksheets
rw = 3 'first row after header
Do
tmp = ws.Cells(rw, 12).Value
If Len(tmp) = 0 Then Exit Do
Set Pws = Nothing
On Error Resume Next
Set Pws = ThisWorkbook.Sheets(tmp)
On Error GoTo 0
If Pws Is Nothing Then
Set Pws = MyBook.Worksheets.Add( _
after:=MyBook.Sheets(MyBook.Sheets.Count))
Pws.Name = tmp
End If
ws.Rows(rw).Copy Pws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
rw = rw + 1
Loop
Next ws 'next worksheet in file;
Wkb.Close False
FileName = Dir()
Loop 'Do next file in folder
Application.EnableEvents = True
Application.ScreenUpdating = True