I am using this script. I am getting Subscript out of range Error in the line below indicated with the comment
'This is the section to customize, replace with your own action code as needed**
I am trying to copy a cell value E3 present in sheet called One Pager to the sheet in file SUMMARY1.xlsm
I am getting the result but I do get the out of range error. No sure what is happening. The code looks for cell E3 in One Pager instances in multiple files.
The folder path = C:\Users\guhaka\OneDrive - Danone\Documents\Portfolio Optimization\rTAM Presentation\Dossier\
Sub Something() '‹~~ Added this to indent the code. Please change to real name
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet
'Setup
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now
Set wsMaster = ThisWorkbook.Sheets("Master") 'sheet report is built into
With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
Cells.Select
Selection.UnMerge
.UsedRange.Offset(1).EntireRow.Clear
NR = 2
Else
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
End If
'Path and filename (edit this section to suit)
fPath = "C:\Users\guhaka\OneDrive - Danone\Documents\Portfolio Optimization\rTAM Presentation\Dossier\" 'remember final \ in this string
fPathDone = fPath & "Imported\" 'remember final \ in this string
On Error Resume Next
MkDir fPathDone 'creates the completed folder if missing
On Error GoTo 0
fName = Dir(fPath & "*.xlsm*") 'listing of desired files, edit filter as desired
'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file
'This is the section to customize, replace with your own action code as needed
Sheets("One Pager").Range("E3").Copy
wbData.Close False 'close file
Workbooks("SUMMARY1.xlsm").Activate
ActiveSheet.Range("E3").Select
ActiveSheet.Paste
Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
fName = Dir 'ready next filename
End If
Loop
End With
ErrorExit: 'Cleanup
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub
Here's how to avoid the overwrite:
'...
'...
'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file
'copy E3 to the next empty cell on the summary sheet
' (adjust sheet/workbook as needed)
wbData.Sheets("One Pager").Range("E3").Copy _
ThisWorkbook.Sheets("Summary").cells(Rows.Count, "E").End(xlUp).offset(1, 0)
wbData.Close False 'close file
Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
fName = Dir 'ready next filename
End If
Loop
'...
'...
Related
I have workbook that has multiple sheets and need a macro button to save a copy of it and delete the sheet named "CSG". This was easy to do, but the problem was that all cell references pointed to the original workbook.
With help, the problem has been tried to solve through name manager and break all links-code. Now the problem is that it break all references within the new workbook and copies only the values from the original workbook.
For example, in the original workbook sheet1 cell A1 has value 10, sheet2 cell A1 has cell reference "='sheet1'!A1". When I make the new copy, both cells do have the value 10, but the reference is no longer there.
Is there a way to keep these references within the workbook without them referencing the original workbook? Below is the code currently being used.
Sub SaveTest()
Dim x As Integer
Dim FileName As String, FilePath As String
Dim NewWorkBook As Workbook, OldWorkBook As Workbook
Set OldWorkBook = ThisWorkbook
With Application
.ScreenUpdating = False: .DisplayAlerts = False
End With
On Error Resume Next
With OldWorkBook.Sheets("CSG")
FilePath = "C:\Users\Tom\Desktop\" & .Range("B1").Value & " " & .Range("B2").Value
FileName = .Range("B1").Value & " " & .Range("B2").Value & ".xlsx"
End With
MkDir FilePath
On Error GoTo -1
On Error GoTo myerror
FilePath = FilePath & "\"
For x = 2 To OldWorkBook.Worksheets.Count
With OldWorkBook.Worksheets(x)
If Not NewWorkBook Is Nothing Then
.Copy after:=NewWorkBook.Worksheets(NewWorkBook.Worksheets.Count)
Else
.Copy
Set NewWorkBook = ActiveWorkbook
End If
End With
Next x
DeleteBadNames NewWorkBook
BreakAllLinks NewWorkBook
UpdateNameManager NewWorkBook
NewWorkBook.SaveAs FilePath & FileName, 51
myerror:
If Not NewWorkBook Is Nothing Then NewWorkBook.Close False
With Application
.ScreenUpdating = True: .DisplayAlerts = True
End With
If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub
Create a Copy of a Workbook
Option Explicit
Sub SaveTest()
Dim OldWorkBook As Workbook: Set OldWorkBook = ThisWorkbook
Dim WorkSheetNames() As String
Dim FilePath As String
Dim FileName As String
With OldWorkBook.Worksheets("CSG")
ReDim WorkSheetNames(1 To .Parent.Worksheets.Count)
FilePath = "C:\Users\Tom\Desktop\" & .Range("B1").Value & " " _
& .Range("B2").Value
FileName = .Range("B1").Value & " " & .Range("B2").Value & ".xlsx"
End With
On Error Resume Next
MkDir FilePath
On Error GoTo 0
FilePath = FilePath & "\"
Dim ws As Worksheet
Dim n As Long
For Each ws In OldWorkBook.Worksheets
n = n + 1
WorkSheetNames(n) = ws.Name
Next ws
Application.ScreenUpdating = False
OldWorkBook.Worksheets(WorkSheetNames).Copy
With ActiveWorkbook ' new workbook
Application.DisplayAlerts = False
.Worksheets("CSG").Delete
.SaveAs FilePath & FileName, 51 ' xlOpenXMLWorkbook
Application.DisplayAlerts = True
'.Close SaveChanges:=False
End With
Application.ScreenUpdating = True
End Sub
I'm looking for a help in a difficult mission.
I have more then 30.000 files in a especific folder (*\backup) in xl?? format and need to read the cell B4. I thought the better idea is use the VBA in Excel to read this specific cell for each file and write on a table A:B.
I believe the following should help you, just remember to amend the declaration for the destination Worksheet name and the full path to the folder where the Workbooks you want to read reside.
The code below will loop through your desired Directory/Folder and read all the files with an .xls* extension, get the value from the first Worksheet in cell B4 and pass this value to the destination worksheet.
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim wsDestination As Worksheet: Set wsDestination = ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet where you want to aggregate the data.
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.CutCopyMode = False
myPath = "C:\backup\"
'set the full path to the folder you want to utilize, remember to add the last \
Last = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row
If Last >= 2 Then wsDestination.Range("A2:B" & Last).ClearContents
'clear the destination worksheet ready to aggregate again
myExtension = "*.xls*"
'Target File Extension (must include wildcard "*")
myFile = Dir(myPath & myExtension)
'Target Path with Ending Extention
Do While myFile <> ""
'Loop through each Excel file in folder
Set wb = Workbooks.Open(Filename:=myPath & myFile)
DoEvents
'Ensure Workbook has opened before moving on to next line of code
wsDestination.Cells(1, "A").Value = "Filename"
wsDestination.Cells(1, "B").Value = "Value From Cell B4"
NextRow = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
wsDestination.Cells(NextRow, "A").Value = myFile
wsDestination.Cells(NextRow, "B").Value = wb.Worksheets(1).Range("B4").Value
wb.Close SaveChanges:=False
'Close Workbook without Saving
DoEvents
'Ensure Workbook has closed before moving on to next line of code
myFile = Dir
'Next File
Loop
MsgBox "Transfer of Data Completed!", vbInformation, "Info"
'Message Box when tasks are completed
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I want to open a workbook that contains only one sheet,
copy data up to column AC until last available row in column A,
paste the data into first empty row in column A in workbook "Mergedsheet.xlsx".
I want to loop over all workbooks present in a specific folder, but get lots of errors.
Sub MergeNew()
Dim WorkBk As Workbook
Dim MergedSheet As Worksheet
Dim SourceData As Range
Dim DestinationData As Range
Dim lastRow As Long
Dim NextRow As Range
Dim FolderPath As String
Dim FileNames As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FolderPath = "E:\Jan to March 2019\Bharuch 31\"
FileNames = Dir(FolderPath & "*.xls*")
Do While FileNames <> ""
Set WorkBk = Workbooks.Open(FolderPath & FileNames)
Range("A1:AC1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Open Filename:="E:\Jan to March 2019\Bharuch 31\MergedSheet.xlsx"
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & lastRow).Select
ActiveSheet.Paste
'ActiveWindow.Close SaveChanges:=True
'ActiveWindow.Close SaveChanges:=False
Application.CutCopyMode = False
FileNames = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
You are looping through a folder and copy-pasting each workbook's first sheet's data to workbook A. However, workbook A is also in that folder. So you should take care to skip it (when looping).
(Alternatively, you could provide a different argument to the DIR function (e.g. some wildcard criteria that excludes workbook A if possible), so that you don't have to constantly check inside the loop.)
Untested.
Option Explicit
Private Sub MergeNew()
'Application.ScreenUpdating = False 'Uncomment this when you know code is working.
'Application.DisplayAlerts = False 'Uncomment this when you know code is working.
Dim folderPath As String
folderPath = GetFolderPath(titleToShow:="Select the folder containing the files to loop through.")
Dim Filename As String
Filename = Dir$(folderPath & "*.xls*")
If Len(Filename) = 0 Then
MsgBox "Could not find a relevant file in '" & folderPath & "'. Code will stop running now."
Exit Sub ' No point in carrying on in such a case.
End If
Dim destinationFolderPath As String
destinationFolderPath = GetFolderPath(titleToShow:="Select the folder to save the 'MergedSheet.xlsx' file to.")
Dim destinationWorkbook As Workbook
Set destinationWorkbook = Application.Workbooks.Add
' This line may throw an error
destinationWorkbook.SaveAs Filename:=destinationFolderPath & "MergedSheet.xlsx", FileFormat:=xlOpenXMLWorkbook
Dim destinationSheet As Worksheet
Set destinationSheet = destinationWorkbook.Worksheets(1) ' I assume there's only 1 sheet in there, but change as necessary.
Do Until Len(Filename) = 0
Dim fullFilePathToOpen As String
fullFilePathToOpen = folderPath & Filename
If fullFilePathToOpen <> destinationWorkbook.FullName Then ' Probably could have just compared filename since directory is the same, but this is more explicit
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Application.Workbooks.Open(Filename:=fullFilePathToOpen, ReadOnly:=True) ' If you don't make changes to the workbook you open, better to open as read-only
Dim sourceSheet As Worksheet
Set sourceSheet = sourceWorkbook.Worksheets(1) ' You say there's only one worksheet in there, so referring by index should be okay (for now)
Dim lastSourceRow As Long
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row ' Assume last row can be determined from column A alone
Dim lastDestinationRow As Long
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row + 1
If destinationSheet.Rows.Count < (lastDestinationRow + lastSourceRow) Then
MsgBox "Ran out of rows (in sheet '" & sourceSheet.Name & "' of workbook '" & destinationWorkbook.Name & "')"
Exit Sub
End If
sourceSheet.Range("A1", sourceSheet.Cells(lastSourceRow, "AC")).Copy Destination:=destinationSheet.Cells(lastDestinationRow, "A")
sourceWorkbook.Close False
End If
Filename = Dir$()
Loop
'Application.ScreenUpdating = True 'Uncomment this when you know code is working.
'Application.DisplayAlerts = True 'Uncomment this when you know code is working.
End Sub
Private Function GetFolderPath(Optional ByVal titleToShow As String = vbNullString) As String
With Application.FileDialog(msoFileDialogFolderPicker)
If Len(titleToShow) > 0 Then .Title = titleToShow
.AllowMultiSelect = False ' Only one is allowed.
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Folder selection appears to have cancelled. Code will stop running now"
End
End If
GetFolderPath = .SelectedItems(1) & "\"
End With
End Function
I am trying to:
open up spreadsheets from a folder of 50
sort and filter the first sheet on each one (the name will be unknown of this sheet)
filtering needs to find each row that has a certain value in column J - this value is 'No'
All rows that meet the criteria (row J contains 'no') need to be then placed onto a master spreadsheet
Each csv should close each time it's been processed
I have spent hours & hours on forums and have some code which I have been tinkering with, but can't get it running together:
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.csv*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
Range("A1:AC3100").Select
Selection.AutoFilter
ActiveWindow.LargeScroll ToRight:=1
Range("Y2").Select
ActiveSheet.Range("$A$1:$AC$3110").AutoFilter Field:=25, Criteria1:="No"
Range("A1:AC3100").Select
Range("Y2").Activate
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Windows("Book1").Activate
Rows("1:1").Select
Selection.Insert Shift:=xlDown
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The spreadsheet data has variable lengths do I made the selection the maximum:
Range("A1:AC3100")
I would assume there is a better way than this too.
Your criterion is a bit too vague to give a perfect response, but I'll take a crack at it. Some parts of your code seem extraneous or convoluted so I'm doing this based on your end goal (all rows where the value in column J for the first sheet in each workbook that contain 'no' are copied into a master spreadsheet).
If all of your worksheets are always in the same folder you can make the myPath static rather than attempting to use the msoFileDialogFolderPicker. When I attempted to run your code on my machine it gave me an "Out of Memory" error, if you have this issue as well I recommend a static string for myPath.
Option Explicit
Sub PutInMasterFile()
Dim wb As Workbook
Dim masterWB As Workbook
Dim rowNum As Integer
Dim copyRange As Range
Dim pasteRange As Range
Dim myPath As String
Dim myFile As String
Dim FirstAddress As String
Dim x As Variant
Dim c As Variant
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
I would advise against disabling Events until you have confirmed your code is running correctly. Worry about getting working code before thinking about optimization.
x = 1
Set masterWB = Workbooks("NAMEOFWORKBOOK")
Set pasteRange = masterWB.Sheets(1).Range("A" & x)
myPath = "C:\EXAMPLE\MOREEXAMPLE\*.csv"
myFile = Dir(myPath)
myPath can be set to search directly for .csv files in the string.
Do While myFile <> vbNullString
Workbooks.Open (myFile)
With Workbooks(myFile).Sheets(1)
Set c = .Range("J:J").Find("No", LookIn:=xlValues, lookat:=xlWhole)
Using .find in vba is preferential to trying to get a filter and then grabbing everything that the filter displays.
If Not c Is Nothing Then
FirstAddress = c.Address
Do
rowNum = c.Row
Set copyRange = .Range(rowNum & ":" & rowNum)
copyRange.Copy
pasteRange.PasteSpecial
x = x + 1
Set pasteRange = masterWB.Sheets(1).Range("A" & x)
Copies in the row into your master sheet. The x = x + 1 guarantees you paste new data onto a new row to avoid overwriting anything.
Set c = .Range("J:J").FindNext(c)
Loop While Not c Is Nothing And FirstAddress <> c.Address
End If
End With
Workbooks(myFile).Close
myFile = Dir()
Closes your first file and gets the next one set up
Set pasteRange = masterWB.Sheets(1).Range("A" & x)
Sets the paste range in the master wb outside of the inner loop, otherwise it will overwrite the values starting at A1 again with the next file.
Loop
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I would also recommend you read up on VBA best practices for any future code you work on such as using Option Explicit and avoiding use of GoTo or .Select wherever possible.
I'm trying to write code that on Commandbutton2_Click searches through the folder that the file is in, takes a value from the same cell in each file and adds these together.
I have this:
Private Sub CommandButton2_Click()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Dim strFolderPath As String
Dim strToolNumber As String
Dim RingCount As Integer
RingCount = 0
strToolNumber = CStr(Sheets("Sheet1").Range("B9").Value)
strFolderPath = "T:\Engineering\Tooling\Tooling Control Engineering\Press Tool Inspection Records\" & strToolNumber & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = strFolderPath
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(FileName:=.FoundFiles(lCount), UpdateLinks:=0)
'DO YOUR CODE HERE
RingCount = Val(RingCount) + ActiveWorkbook.Sheets("Sheet1").Range("F11").Value
wbResults.Close SaveChanges:=False
Next lCount
End If
End With
On Error GoTo 0
ActiveSheet.Unprotect Password:=""
ActiveWorkbook.Sheets("Sheet1").Range("F13").Value = (RingCount + ActiveWorkbook.Sheets("Sheet1").Range("F11").Value)
ActiveSheet.Protect Password:=""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
whose main body was pieced together from different google searches - but it continually returns a value of 0 (despite the cells in the other sheets having values).
I read somewhere that Application.Filesearch does not work for versions of Excel later than 2003, could this be the source of the problem?
Its possible to pull that value youre interested in without opening each workbook. Its much more efficient and reliable.
This code iterates through all files in the path variable and pulls values without opening the Excel files. It then prints the values starting at F20. You can then make another wrapper function to sum them up and delete or whatever you want. Hope this helps
Private Sub CommandButton2_Click()
Dim tool As String
tool = CStr(Sheets("Sheet1").range("B9").Value)
Dim path As String
path = "T:\Engineering\Tooling\Tooling Control Engineering\Press Tool Inspection Records\" & strToolNumber & "\"
Dim fname
fname = Dir(CStr(path)) ' gets the filename of each file in each folder
Do While fname <> ""
If fname <> ThisWorkbook.Name Then
PullValue path, fname ' add values
End If
fname = Dir ' get next filename
Loop
End Sub
Private Sub PullValue(path As String, ByVal fname As String)
With range("F" & (range("F" & Rows.Count).End(xlUp).Row + 1))
.Formula = "='" & path & "[" & fname & "]Sheet1'!F11"
.Value = .Value
End With
End Sub