I have a problem with a macro, I have a sample file with a button that I would like to use to run two files in the background. One wb = this is a template and wbMe pli with data that I would like to copy to wbMe. However, when I run the code, I get subcprite out of range. Where I have an error, such a sheet exists + there is data there in the cell
Sub COREP_ITS()
Dim strPath As String
Set wb = ThisWorkbook
Set wbMe = ThisWorkbook
strPath = selectFile
If strPath = "" Then Exit Sub
Set wbMe = ThisWorkbook
MyFolder = "sample_folder"
MyFile = Dir(MyFolder & "\CMR - CJ_MINIMAL*.xlsx")
If MyFile <> "" Then
Set wb = Workbooks.Open(MyFolder & "\" & MyFile, UpdateLinks:=0)
Else
Exit Sub
End If
''C_0700_002''
wbMe.Sheets("Tabela_COREP").Range("F14").Copy
wb.Sheets("C_0700_0002").Range("G14").PasteSpecial Paste:=xlPasteValues
End Sub
Private Function selectFile()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = ActiveWorkbook.Path
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel", "*.xlsx"
If .Show = True Then selectFile = .SelectedItems(1)
End With
End Function
You don't open the user-selected file.
You need to pass strPath to Workbooks.Open
strPath = selectFile
If strPath = "" Then Exit Sub
Set wbMe = Workbooks.Open(strPath)
Related
My Aim:
This procedure is meant to loop through excel files in a specified folder and preform a sub (cleanDataAndTransfer), which is meant to clean the data in the files being looped through and then paste it in to a new sheet in the master file.
My problem:
Im getting the Run-time error '91': Object variable or With block variable not set on the .Title = "Select A Target Folder" line.
I've tried different solutions to rectify the issue but nothing has yet worked.
My code:
Sub loopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
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
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
myExtension = "*.xls*"
myFile = Dir(myPath & myExtension)
Do While myFile <> ""
Set wb = Workbooks.Open(FileName:=myPath & myFile)
DoEvents
Call cleanDataAndTransfer
wb.Close SaveChanges:=True
DoEvents
myFile = Dir
Loop
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I would really appreciate any suggestions on how to solve this bug and any other improvements! Thanks in advance :)
I don't have a Mac to test this but you could try an InputBox.
update - no filter on Dir
Sub loopAllExcelFilesInFolder()
Sub loopAllExcelFilesInFolder2()
Const EXT = "csv"
Dim wb As Workbook, myPath As String, myFile As String
Dim count As Integer, isWindows As Boolean
myPath = ThisWorkbook.Path & Application.PathSeparator
myPath = VBA.InputBox("Enter folder", "Folder", myPath)
If myPath = "" Then Exit Sub
If Right(myPath, 1) <> Application.PathSeparator Then
myPath = myPath & Application.PathSeparator
End If
myFile = Dir(myPath)
Do While myFile <> ""
If Right(myFile, Len(EXT)) = EXT Then
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Call cleanDataAndTransfer
wb.Close SaveChanges:=True
count = count + 1
End If
myFile = Dir
Loop
MsgBox count & " files cleaned", vbInformation
End Sub
I have a macro excel file that does some clean up on cells and I need to import a single sheet from various files on the same folder. For example I need the sheet1 from all the excel files located on the same folder as my macro file. I have a code to do that manually but I need to be able to do it automatically either by selecting the files or running another macro to select them no matter the amount of files on the folder.
Sub Carga_Masiva()
Dim fName As String, wb As Workbook
fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
sh.Copy Before:=ThisWorkbook.Sheets(1)
Exit For
End If
Next
wb.Close False
End Sub
I'd prompt user for a folder and then iterate over each file except the one with your macro.
To prompt for a folder use this solution (in my code as optional variant): link
Complete code below:
Sub Carga_Masiva()
Dim sh As Worksheet
Dim fName As String, wb As Workbook
fName = Application.GetOpenfnamename("Excel fnames (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
sh.Copy Before:=ThisWorkbook.Sheets(1)
Exit For
End If
Next
wb.Close False
End Sub
Sub CopyToThisWorkbook()
Dim wbMacro, wb As Workbook
Set wbMacro = ThisWorkbook
Dim sh As Worksheet
Dim folderPath, fName, tabName As String
folderPath = wbMacro.Path & Application.PathSeparator
'Prompt variant
'folderPath = GetFolder & Application.PathSeparator
fName = Dir(PathName:=folderPath)
Do
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Open all files except the one with macro
If fName <> wbMacro.Name Then
'Your code
Set wb = Workbooks.Open(wbMacro.Path & "\" & fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
tabName = sh.Name & "_" & Right(wb.Name, 10) 'Optional - rename Worksheet to be copied
sh.Name = tabName 'Optional
sh.Copy Before:=wbMacro.Sheets(1)
Exit For
End If
Next sh
wb.Close SaveChanges:=False
End If
fName = Dir
Loop Until fName = ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function GetFolder() As String 'Optional variant
Dim fldr As fnameDialog
Dim sItem As String
Set fldr = Application.fnameDialog(msofnameDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialfnameName = Application.DefaultfnamePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
I've got am csv file which looks as follows
When I select all cells and copy/paste it manually into another excel file the result is the same as the original. Howevever, trying to do the same in VBA gives me the following result.
This is the code I am using.
Sub test()
Dim arr1 As Object
Set arr1 = CreateObject("System.Collections.ArrayList")
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
'-----------------------------------------------------------
Dim FileName As Variant
FileName = Dir(GetFolder & "\")
'-----------------------------------------------------------
While FileName <> ""
arr1.Add GetFolder & "\" & FileName
FileName = Dir
Wend
'-----------------------------------------------------------
Set fldr = Nothing
Dim i As Long
For i = 0 To arr1.Count - 1
'-------------------------------------------------------------------
Dim wkbk As Workbook
Set wkbk = Workbooks.Open(arr1(i))
wb1 = wkbk.Name
Set sht = wkbk.Worksheets(wkbk.Sheets(1).Name)
wkbk.Sheets(sht.Name).Copy After:=ThisWorkbook.Sheets("START")
ActiveSheet.Name = "NEW"
' MsgBox wkbk.Name
' ThisWorkbook.Sheets.Add.Name = "NEW"
' wkbk.Sheets(sht.Name).Cells.Copy
' ThisWorkbook.Sheets("NEW").Cells.Paste
wkbk.Close False
Next i
End Sub
Is there a way to get the same result as doing it manually?
Import CSV Files
Option Explicit
Sub importCSV()
Const InitialFolderPath As String = "F:\Test\2021"
Const FilePattern As String = "*.csv"
Dim dwb As Workbook: Set dwb = ThisWorkbook
Dim FolderPath As String
If Right(InitialFolderPath, 1) = "\" Then
FolderPath = InitialFolderPath
Else
FolderPath = InitialFolderPath & "\"
End If
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select"
.AllowMultiSelect = False
.InitialFileName = FolderPath
If .Show = False Then
MsgBox "You canceled."
Exit Sub
End If
FolderPath = .SelectedItems(1) & "\"
End With
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim FileName As String: FileName = Dir(FolderPath & FilePattern)
Do While FileName <> ""
arl.Add FolderPath & FileName
FileName = Dir
Loop
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim dws As Worksheet
Dim shId As Long
Dim i As Long
For i = 0 To arl.Count - 1
Set swb = Workbooks.Open(FileName:=arl(i), Local:=True)
Set sws = swb.Worksheets(1)
sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
Set dws = ActiveSheet
shId = shId + 1
On Error GoTo NewSheetError
dws.Name = "New" & shId
On Error GoTo 0
swb.Close False
Next i
'dwb.Save
Application.ScreenUpdating = True
Exit Sub
NewSheetError:
shId = shId + 1
Resume
End Sub
I am trying to copy a sheet from one file and then paste it to an established tab in about 6 files in an established folder. I have this code, but it only works for the first file in the folder. It is also creating a blank workbook for some reason. Any suggestions?
Sub LoopThroughFiles()
Dim wbk As Workbook
Dim Filename As String
Dim FirstFile As String
Dim FileDirectory As String
Dim x As Workbook
Set x = Workbooks.Open("test.xlsx")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
Else
FileDirectory = .SelectedItems(1) & "\"
End If
End With
Set wbk = Workbooks.Add
Filename = Dir(FileDirectory)
FirstFile = Filename
Do Until Filename = ""
Dim new_wb As Workbook
Set new_wb = Workbooks.Open(FileDirectory & Filename)
If FirstFile = Filename Then
x.Sheets("report").UsedRange.Copy
new_wb.Sheets("roster").Range("a1").PasteSpecial
End If
new_wb.Close savechanges:=True
Filename = Dir
Loop
MsgBox "All store totals have been added"
End Sub
Sub LoopThroughFiles_Paste_Roster()
Dim wbk As Workbook 'New workbook the data is added to
Dim Filename As String
Dim FirstFile As String
Dim FileDirectory As String
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("Copy Doc 1")
Set y = Workbooks.Open("Copy Doc 2")
'display the folder picker dialog box so user can select a folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
Else
FileDirectory = .SelectedItems(1) & "\"
End If
End With
'retrieve the name of the first file in the folder using Dir
Filename = Dir(FileDirectory)
FirstFile = Filename
'Loop through all the files in the folder
'open the file
Do Until Filename = ""
Set wbk = Workbooks.Open(FileDirectory & Filename, UpdateLinks:=False, Password:="Password123")
With wbk
x.Sheets("report").UsedRange.Copy
wbk.Sheets("roster").Range("a1").PasteSpecial
y.Sheets("Setup").UsedRange.Copy
wbk.Sheets("PTO Taken and Req").Range("a1").PasteSpecial
End With
'save and close the file
'get the next file in the folder
wbk.Close savechanges:=True
Filename = Dir
Loop
MsgBox "All pages have been updated"
End Sub
I have written the following code in VBA. When debugging, I am not able to find any problems. It is not creating nor converting any file into .CSV.
Sub SaveToCSVs()
Dim fDir As String
Dim Wb As Workbook
Dim wS As Worksheet
Dim csvWs As String, csvWb As String
Dim extFlag As Long '0 = .xls & 1 = .xlsx extension types
Dim fPath As String
Dim sPath As String, dd() As String
fPath = "C:\Users\DA00358662\Documents\XLSCONV\*.*"
sPath = "C:\Users\DA00358662\Documents\XLSCONV\"
fDir = Dir(fPath)
extFlag = 2
Do While (fDir <> "")
If Right(fDir, 4) = ".xls" Or Right(fDir, 5) = ".xlsx" Then
extFlag = 0
Else
extFlag = 2
End If
On Error Resume Next
If extFlag = 0 Then
fDir = Dir
Set Wb = Workbooks.Open(fPath & fDir)
csvWb = Wb.Name
dd = Split(csvWb, ".")
For Each wS In Wb.Sheets
wS.SaveAs dd(0) & wS.Name & ".csv", xlCSV
Next wS
Wb.Close False
Set Wb = Nothing
fDir = Dir
On Error GoTo 0
End If
Loop
End Sub
with this code (standard for my use) you can find that you need (modify as your need).
In short the code ask which directory to loop and for each file, with the corresponding extension, in this directory it open file, save as csv in the some directory, and close the original file.
Sub SaveAsCsv()
Dim wb As Workbook
Dim sh As Worksheet
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 Exit Sub
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'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)
nameWb = myPath & Left(myFile, InStr(1, myFile, ".") - 1) & ".csv"
ActiveWorkbook.SaveAs Filename:=nameWb, FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
'Get next file name
myFile = Dir
Loop
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
The Moment you concatenate fPath and fDir to open your Workbook, you get something like:
"C:\Users\DA00358662\Documents\XLSCONV\*.*MyWorkbook.xls"
Note *.* in the middle ruining your day. I think you want to use sPath here?