Need to modify my VBA code to include subfolders as well - vba

I have created a VBA code that loops through all excel workbooks in a given folder , opens then, refreshes the sheet, pauses for 10 seconds, closes and saves and moves on to the next. The issue I am facing is that it wont do it for the excel workbooks in the subfolder, Please can someone assist.
The code is as per below:
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 = "*.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)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Change First Worksheet's Background Fill Blue
Application.Calculate
ActiveWorkbook.RefreshAll
Application.Wait (Now + TimeValue("0:00:10"))
'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

Its probably an old question indeed, but still, I enjoyed writing it somehow. And in my solution, you get some nice printing in the console. Here you go:
Option Explicit
Function GetFiles(ByVal Folder As String) As Collection
Dim strFile As String
Set GetFiles = New Collection
strFile = Dir(Folder & "\*")
Do While strFile <> ""
GetFiles.Add strFile
strFile = Dir
Loop
End Function
Function GetFolders(ByVal Folder As String) As Collection
Dim strFile As String
Set GetFolders = New Collection
strFile = Dir(Folder & "\*", vbDirectory)
Do While strFile <> ""
If GetAttr(Folder & "\" & strFile) And vbDirectory Then GetFolders.Add strFile
strFile = Dir
Loop
End Function
Sub LoopThroughSubfoldersAsWell()
Dim colFoFi As Collection
Dim varEl01 As Variant
Dim varEl02 As Variant
Dim varEl03 As Variant
Dim strLine As String: strLine = "--------------------------"
Dim strAddress As String: strAddress = "C:\Users\UserName\Desktop\Testing01\"
Debug.Print strAddress
Set colFoFi = GetFiles(strAddress)
For Each varEl01 In colFoFi
Debug.Print varEl01
Next varEl01
Debug.Print strLine
Set colFoFi = GetFolders(strAddress)
For Each varEl01 In colFoFi
If Len(varEl01) > 2 Then 'to avoid some hidden stuff
Set varEl02 = GetFiles(strAddress & varEl01)
Debug.Print (strAddress & varEl01)
For Each varEl03 In varEl02
Debug.Print varEl03
Next varEl03
Debug.Print strLine
End If
Next varEl01
End Sub

Related

VBA code to format 6 excel sheets with multiple tabs by offsetting table data by a few rows

not my code completely.borrowed it from net with my changes in between
PURPOSE: To loop through all Excel files in a user specified folder and
perform a set task on them
SOURCE: www.TheSpreadsheetGuru.com
Sub LoopAllExcelFilesInFolder()
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
Application.DisplayAlerts = False
Application.EnableEvents = False
'Retrieve Target Folder Path From User
myPath = ThisWorkbook.Worksheets(1).Range("B1").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B2").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B3").Value & "\"
End Sub
not my code completely.borrowed it from net with my changes in between
PURPOSE: To loop through all Excel files in a user specified folder and
perform a set task on them
SOURCE: www.TheSpreadsheetGuru.com
Sub LoopAllExcelFilesInFolder()
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
Application.DisplayAlerts = False
Application.EnableEvents = False
'Retrieve Target Folder Path From User
myPath = ThisWorkbook.Worksheets(1).Range("B1").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B2").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B3").Value & "\"
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'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)
WS_Count = wb.Worksheets.Count
' Begin the loop.
'Ensure Workbook has opened before moving on to next line of code
DoEvents
For I = 1 To WS_Count
'Change First Worksheet's Background Fill Blue
'following snippet arranges data in the 4th row and colors it
With wb.Worksheets(I)
If (Range("A1") <> "") Then
'Find the last used row in a Column: column A in this example
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim LastCol As Integer
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
LastColcell = Cells(1, LastCol).Address
Range("A1:" & LastColcell).Font.Color = vbWhite
Range("A1:" & LastColcell).Interior.Color = RGB(51, 98, 174)
Rows("1:3").Insert Shift:=xlDown
Range("G1").FormulaR1C1 = "=SUBTOTAL(9,R[5]C:R[" & LastRow & "]C)"
Range("G1").AutoFill Destination:=Range("G1:" & LastColcell)
Range("G1:" & LastColcell).Interior.Color = RGB(255, 255, 0)
AutoFilterMode = False
End If
End With
Next I
'Save and Close Workbook
Dt = Format(Date, "yyyymmdd")
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

Copy Entire column into an array in excel vba

I am trying to develop a macro which will open excel files specified by user-prompted location, find a specific column and paste the entire column in the active workbook. So far I have written the code which can loop through the files in the directory, opens the file, search for the column and store the entire column in an array. Now whenever I am trying a Run Time Error saying "Overflow"! Can anyone help me to fix this issue? Also, I want to integrate below item in the macro:
1. Find multiple columns from each file and paste those columns in a sheet. So for multiple files, I should paste the columns in individual worksheet dynamically. How can I do that? Any help is appreciated. Thanks. Below is my code I have written so far:
Sub Test_Template()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String, myFile As String
Dim myExtension As String
Dim t As Range, rng As Range, rng2 As Range
Dim dblAvg As Single, eng_spd As Single, i As Integer
Dim FldrPicker As FileDialog
Dim rowCtr As Integer
Dim myarray1 As Variant
rowCtr = 2
'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 = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Execute:
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
'Find "Time" in Row 1
With wb.Worksheets(1).Rows(9)
Set t = .Find("Time", lookat:=xlPart)
'If found, copy the column to Sheet 2, Column A
'If not found, present a message
If Not t Is Nothing Then
'Columns(t.Column).EntireColumn.Copy _
' Destination:=Sheets(3).Range("A1")
Set rng2 = Columns(t.Column)
myarray1 = rng2
Else: MsgBox "Time Not Found"
End If
End With
'Save and Close Workbook
wb.Close 'SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
With ActiveSheet
For i = LBound(myarray1) To UBound(myarray1)
Debug.Print myarray1(i, 1)
Next
End With
'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
here is your code with clutter, like goto commands, and unused With commands removed
Sub Test_Template()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String, myFile As String
Dim myExtension As String
Dim t As Range, rng As Range, rng2 As Range
Dim dblAvg As Single, eng_spd As Single, i As Long
Dim FldrPicker As FileDialog
Dim rowCtr As Long
Dim myarray1 As Variant
rowCtr = 2
' 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 = True Then
myPath = .SelectedItems(1) & "\"
End If
End With
myPath = myPath ' In Case of Cancel
If myPath <> "" Then
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) ' Set variable equal to opened workbook
DoEvents ' yield processing time to other events
Set t = wb.Worksheets(1).Rows(9).Find("Time", lookat:=xlPart) ' Find "Time" in Row 1 ????
If Not t Is Nothing Then
' Columns(t.Column).EntireColumn.Copy _
Destination:=Sheets(3).Range("A1")
myarray1 = Columns(t.Column) ' found: copy the column to Sheet 2, Column A
Else
MsgBox "Time Not Found"
End If
wb.Close ' SaveChanges:=True ' Save and Close Workbook
DoEvents ' yield processing time to other events
For i = LBound(myarray1) To UBound(myarray1)
Debug.Print myarray1(i, 1)
Next
myFile = Dir ' Get next file name
Loop
' MsgBox "Task Complete!"
End If
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

VBA Looping through excel files in selected directory - Copy data and paste in different sheets

I'm looking to select a directory and then loop through each xlsm file within that directory. For each loop it should open the file, copy a range and paste into the current workbook under a specific sheet.
I.e. the first file will paste into sheet1 the second opened file will past into sheet 2, and so on.
I have some code, now I need help to get it to paste the rang into a sheets.count? or something like that. At the moment it just pastes into sheet 1 because that is static.
Sub Test()
Dim wb As Workbook, wb1 As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Set wb1 = Workbooks(ThisWorkbook.Name)
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 = "*.xlsm"
'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
'Copy data from opened workbook
wb.Sheets("HI Sub-segment split").Range("A1:Z1").Copy
'Paste data into destination workbook
wb1.Sheet(1).Range("A1:Z1").PasteSpecial xlPasteValues
'Close Workbook
wb.Close
'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 "Import Complete!"
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Worked with this...
Sub Testing()
'
'
'
Dim wb As Workbook, wb1 As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim loop_ctr As Integer
Set wb1 = Workbooks(ThisWorkbook.Name)
loop_ctr = 1
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 = "*.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)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Copy data from opened workbook
wb.Sheets("Sheet1").Range("A1:B2").Copy
'Paste data into destination workbook
wb1.Sheets(loop_ctr).Range("A1:B2").PasteSpecial xlPasteValues
'Close Workbook
wb.Close
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
'Update loop_ctr value
loop_ctr = loop_ctr + 1
Loop
'Message Box when tasks are completed
MsgBox "Import Complete!"
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Loop coding aborts unexpectedly

I am using a code to loop through all files in a user specified folder and perform a task.
The codes begins executing and then unexpectedly aborts. The first attempt aborted after about 40 files. The second attempt went as far as 177 files. Upon aborting the results to that point are appearing and are accurate.
Does anyone have any idea as to why it may be aborting and/or a different solution. the destination folder has about 7000 files needing data extracted. See existing code below.
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim Folder As String
Dim MacroFile As String
Dim RowCTR As Integer
MacroFile = "Transportation Contact List.xlsm"
Application.ScreenUpdating = 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 = "*.xls"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
RowCTR = 2
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Windows("\\ATLP3FILE5\shared\AITransport\AITFILES_mig-103009\AITUW\LDM\CIF").Activate
'CUT AND PASTE SECTION
Workbooks(myFile).Activate
Worksheets("CIF").Range("F5").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("A" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("h10").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("B" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("h12").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("C" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("D13").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("D" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("s64").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("E" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("Y5").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("F" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("X10").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("G" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("AB11").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("H" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("W9").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("I" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
'Save and Close Workbook
wb.Close SaveChanges:=False
'Get next file name
myFile = Dir
RowCTR = RowCTR + 1
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I've taken your code and tightened it up by removing all of the workbook.activate commands. Likewise, I've used direct value transfer in place of the clipboard's copy & paste special, values.
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook, wsMFS1 As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim Folder As String
Dim MacroFile As String
Dim RowCTR As Integer
MacroFile = "Transportation Contact List.xlsm"
Application.ScreenUpdating = 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 = "*.xls"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
RowCTR = 2
Set wbMF = Workbooks(MacroFile).Worksheets("Sheet1")
'Loop through each Excel file in folder
Do While CBool(Len(myFile))
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
With wb.Worksheets("CIF")
'Windows("\\ATLP3FILE5\shared\AITransport\AITFILES_mig-103009\AITUW\LDM\CIF").Activate
'CUT AND PASTE SECTION
wsMFS1.Range("A" & RowCTR) = .Range("F5").Value
wsMFS1.Range("B" & RowCTR) = .Range("H10").Value
wsMFS1.Range("C" & RowCTR) = .Range("H12").Value
wsMFS1.Range("D" & RowCTR) = .Range("D13").Value
wsMFS1.Range("E" & RowCTR) = .Range("S64").Value
wsMFS1.Range("F" & RowCTR) = .Range("Y5").Value
wsMFS1.Range("G" & RowCTR) = .Range("X10").Value
wsMFS1.Range("H" & RowCTR) = .Range("AB11").Value
wsMFS1.Range("I" & RowCTR) = .Range("W9").Value
End With
'Save and Close Workbook
wb.Close SaveChanges:=False
Set wb = Nothing
'Get next file name
myFile = Dir
RowCTR = RowCTR + 1
Loop
Set wbMF = Nothing
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I don't know if that will save enough resource to finish off your long task but it should make some improvements.

How to move Workbooks from one folder to another with conditions?

There is a ready script that counts number of rows in Workbooks from a selected folder. In case number of rows in any workbook is more than 1, this workbook is copied and saved into another folder.
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
Dim TargetWB As Workbook
MyFolder = GetFolder("C:\Users\user\Desktop")
MyFile = Dir(MyFolder & "*.*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
Set TargetWB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile & "*.*")
With TargetWB
If CountUsedRows(TargetWB) > 1 Then
.SaveAs "C:\Users\user\Desktop\vba\" & MyFile
End If
.Close
End With
MyFile = Dir
Loop
'Workbooks.Close savechanges:=False
Shell "explorer.exe C:\Users\user\Desktop\vba", vbMaximizedFocus
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Function CountUsedRows(Wbk As Workbook) As Long
Dim WS As Worksheet
Set WS = Wbk.Sheets(1)
CountUsedRows = WS.Range("A" & Rows.Count).End(xlUp).Row
End Function
Is it possible to move a Worbook to another folder insted of coping it in case it contains more than 1 row.
And is it possible to use something like: Workbooks.Close savechanges:=False in order to close chosen Workbooks after rows counting? Thanks!
You can move a file easily using the MoveFile method of FileSystemObject object. To use this type with early binding add a reference to Microsoft Sripting Runtime in your VBA project.