Previously I was having issues with the lrSource variable not referencing the correct worksheet, but I added code to fix this issue. Before I corrected the issue, the code would paste some data into "MASTER.xlsx" but not the correct portions due to the lrSource variable not getting the correct last row. Now, I can get the correct last row and I don't receive any errors, but no data is copied to the file destination ("MASTER.xlsx")...Any suggestions?
Sub btnUpdateSAPData_Click()
'Declaring and Setting Variables
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim MyDir As String
Dim fil As Scripting.file
Dim FolderSource As Scripting.Folder
Dim FolderPathDest As String, wbDest As Workbook, wsDest As Worksheet
Dim wbSource As Workbook, wsSource As Worksheet
Dim lrDest As Long, fileDest As String, lrSource As Long
Dim CurrentFile As String
Dim fileSource As String
MyDir = "C:\Users\quirk\Desktop\Cory Project\Wave 1A Content\SAPCL Spreadsheets\July 2018"
'Defining destination characteristics
FolderPathDest = "C:\Users\quirk\Desktop\Cory Project\VBA Code\Master FOlder"
fileDest = "C:\Users\quirk\Desktop\Cory Project\VBA Code\Master FOlder\MASTER.xlsx"
'Workbooks.Open Filename:=fileDest
Set wbDest = ActiveWorkbook ' Workbooks("MASTER.xlsx")
Set wsDest = wbDest.Worksheets("Sheet1")
'Looping through files
Set FolderSource = fso.GetFolder(MyDir)
For Each fil In FolderSource.Files
Debug.Print fil.Name
CurrentFile = fil.Name
If Not fso.FileExists(FolderPathDest & "\" & fil.Name) Then
fso.CopyFile _
Source:=MyDir & "\" & fil.Name _
, Destination:=FolderPathDest & "\" & fil.Name
fileSource = MyDir & "\" & fil.Name
Workbooks.Open Filename:=fileSource '
ActiveWindow.Visible = False
Set wbSource = Workbooks(CurrentFile)
Set wsSource = wbSource.Worksheets(1)
lrSource = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row
lrDest = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row + 1
Range("A2:V" & lrSource).Copy Destination:=wsDest.Range("A" & lrDest)
End If
Next fil
End Sub
Related
The code I have loops through a folder that has 100+ files (with more files being added daily) and copies files, data, etc. Every file that I loop through ends up in the VBA Project Explorer as you can see from the picture. This is really slowing down the run time of my code. Is there any way I can prevent each workbook from being added to the Project Explorer? Also, I haven't run my code with the optimize subroutines that I call to because I added those after running my original code (and now the editor is basically frozen). I attached my code as well as the picture of my issue below!
Sub TransferSAPCLData_Click()
'Code Optimization
Call OptimizeCode_Begin
'Declaring and Setting Variables
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim MyDir As String
Dim fil As Scripting.file
Dim FolderSource As Scripting.Folder
Dim FolderPathDest As String, wbDest As Workbook, wsDest As Worksheet
Dim wbSource As Workbook, wsSource As Worksheet
Dim lrDest As Long, fileDest As String, lrSource As Long
Dim CurrentFile As String
Dim fileSource As String
MyDir = "C:\Users\quirk\Desktop\Cory Project\Wave 1A Content\SAPCL Spreadsheets\SAPCL Raw Data Files"
'Defining destination characteristics
FolderPathDest = "C:\Users\quirk\Desktop\Cory Project\Wave 1A Content\Master SAPCL Folder"
fileDest = "C:\Users\quirk\Desktop\Cory Project\Wave 1A Content\Master SAPCL Folder\Function Master File.xlsm"
'Workbooks.Open Filename:=fileDest
Set wbDest = ActiveWorkbook ' Workbooks("MASTER.xlsx")
Set wsDest = wbDest.Worksheets("Sheet1")
'Looping through files
Set FolderSource = fso.GetFolder(MyDir)
For Each fil In FolderSource.Files
Debug.Print fil.Name
CurrentFile = fil.Name
If Not fso.FileExists(FolderPathDest & "\" & fil.Name) Then
fso.CopyFile _
Source:=MyDir & "\" & fil.Name _
, Destination:=FolderPathDest & "\" & fil.Name
fileSource = MyDir & "\" & fil.Name
Workbooks.Open Filename:=fileSource '
ActiveWindow.Visible = False
Set wbSource = Workbooks(CurrentFile)
Set wsSource = wbSource.Worksheets(1)
lrSource = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row
lrDest = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row + 1
wsSource.Range("A2:V" & lrSource).Copy Destination:=wsDest.Range("A" & lrDest)
End If
Next fil
'Optimize Code
Call OptimizeCode_End
End Sub
I would like to create new files (in the same folder) from sheet "lista strategiczna".D2 only if doesn't exist. Next offset one position down, and create next files etc. What I doing wrong?
Sub TworzenieZamowien()
Dim thisWb As Workbook
Dim nazwaPliku As String
Set thisWb = ActiveWorkbook
Dim aktywnaKomorka As Range
Set aktywnaKomorka = Sheets("lista strategiczna").Range("D2")
Dim FilePath As String
FilePath = Dir(ActiveWorkbook.Path, vbDirectory)
Do Until aktywnaKomorka = ""
nazwaPliku = thisWb.Path & "\Zamówienie " & aktywnaKomorka & ".xls"
If FilePath <> nazwaPliku Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=nazwaPliku
ActiveWorkbook.Close savechanges:=False
aktywnaKomorka.Offset(1, 0).Select
Else
aktywnaKomorka.Offset(1, 0).Select
End If
Loop
End Sub
I would set your range at the start, use a For loop and do away with selecting things (rarely a good idea). Your current code doesn't change aktywnaKomorka(it remains D2), you just activate the next cell below but your loop does not reference the active cell.
Sub TworzenieZamowien()
Dim thisWb As Workbook
Dim nazwaPliku As String
Set thisWb = ActiveWorkbook
Dim aktywnaKomorka As Range
With Sheets("lista strategiczna")
Set aktywnaKomorka = .Range("D2", .Range("D" & Rows.Count).End(xlUp))
End With
Dim FilePath As String, r As Range
FilePath = Dir(ActiveWorkbook.Path, vbDirectory)
For Each r In aktywnaKomorka
If r <> vbNullString Then
nazwaPliku = thisWb.Path & "\Zamówienie " & r & ".xls"
If FilePath <> nazwaPliku Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=nazwaPliku
ActiveWorkbook.Close savechanges:=False
End If
End If
Loop
End Sub
If you wanted to persist with your Do loop rather than Select add this line
set aktywnaKomorka=aktywnaKomorka.Offset(1, 0)
I'm not good with VBA at all but I was curious to know if there is a way to count the amount of worksheets in a workbook that's looped for all the files in a folder.
For example, A1 list the file names and B1 shows the count of sheets.
A1 B1
book1 5
book2 6
currently have this code set up and need to adjust it
Sub ListAllFile()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim ws As Worksheet
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = Worksheets.Add
Set objFolder = objFSO.GetFolder("W:\101g-19 (4.20.18) - Copy\")
ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & " are:"
For Each objFile In objFolder.Files
ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name
'ADD A WORKSHEET AND PASTE "=SHEETS()" in A1 the copy value of a1 in to list
'close files with out saving
Next
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Sub
Take a look at the below - note that you should run this from inside of a blank worksheet
Set CurrentWB = ActiveWorkbook
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim J As Long
Dim N As Long
Dim lc As Long
Dim lr As Long
'UPDATE FOLDER PATH OF WHERE XLS FILES ARE LOCATED
folderPath = "C:\Users\username\Desktop\test\" 'change to suit
J = 2
' Column Headers
CurrentWB.Sheets(1).Range("A1").Value = "Filename"
CurrentWB.Sheets(1).Range("B1").Value = "# of Sheets"
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
'YOU CAN CHANGE TO BE ANY FILE TYPE BUT CURRENTLY SET TO .XLSX
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Application.ScreenUpdating = False
Set TempWB = Workbooks.Open(folderPath & Filename)
' Counts Per Worksheet
N = ActiveWorkbook.Worksheets.Count
CurrentWB.Sheets(1).Range("A" & J).Formula = Filename
CurrentWB.Sheets(1).Range("B" & J).Formula = N
' Close Temporary Workbook
TempWB.Close False
J = J + 1
Filename = Dir
Loop
In your for loop, open the file (assuming they are all excel here) and get the count of worksheets.
Something like:
For Each objFile In objFolder.Files
writeCell = ws.Cells(ws.UsedRange.Rows.Count + 1, 1)
writeCell.Value = objFile.Name
'ADD A WORKSHEET AND PASTE "=SHEETS()" in A1 the copy value of a1 in to list
'close files with out saving
Set wb = Workbooks.Open(objFile.Name)
writeCell.Offset(,1).value = wb.Worksheets.Count()
wb.Close(false)
Next
Sub ListallFiles()
Dim sFileName As String
Dim sFolderPath As String: sFolderPath = "C:\Temp\" ' Change folder path. Ensure that folder path ends with "\"
Dim oWB As Workbook
Dim oWS As Worksheet
' Get the first excel file name from specified folder
sFileName = Dir(sFolderPath & "*.xls*")
' Add a worksheet
Set oWS = ThisWorkbook.Worksheets.Add
With oWS
' Set folder name in the new sheet
.Range("A1").Value = "The file found in " & sFolderPath & " are:"
' Loop through all excel files in the specified folder
Do While Len(Trim(sFileName)) > 0
' Open workbook
Set oWB = Workbooks.Open(sFolderPath & sFileName)
' Set workbook details in the file
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Value = sFileName
.Range("B" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Value = oWB.Worksheets.Count
' Close workbook
oWB.Close False
' Clear workbook object
Set oWB = Nothing
' Get next excel file
sFileName = Dir()
Loop
End With
End Sub
Above UDF should open all files in the specified folder and give you the number of worksheets in each workbook on a new worksheet
I'm running a VBA script in order to count number of rows in each file in a selected folder and then to display it in an active Workbook.
Option Explicit
Sub CountRows()
Dim wbSource As Workbook, wbDest As Workbook
Dim wsSource As Worksheet, wsDest As Worksheet
Dim strFolder As String, strFile As String
Dim lngNextRow As Long, lngRowCount As Long
Application.ScreenUpdating = False
Set wbDest = ActiveWorkbook
Set wsDest = wbDest.ActiveSheet
strFolder = Dir(Range("C7").Value)
strFile = Dir(strFolder & "*.xlsx")
lngNextRow = 11
Do While Len(strFile) > 0
Set wbSource = Workbooks.Open(Filename:=strFolder & strFile)
Set wsSource = wbSource.Worksheets(1)
lngRowCount = wsSource.UsedRange.Rows.Count
wsDest.Cells(lngNextRow, "F").Value = lngRowCount
wbSource.Close savechanges:=False
lngNextRow = lngNextRow + 1
strFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
Chooing a folder, I would like to use the directory that is inserted in an active WorkBook cell "C7" instead of writing a directory in a script.
I tried to substitute:
strFolder = "C:\Users\user\Desktop\"
with
strFolder = Dir(Range("C7").Value)
but it does not work. Maybe someone has any ideas? Thanks!
This line strFolder = Dir(Range("C7").Value) finds firts file in directory (from C7) and then writes path of this file into variable strFolder (say, C:\temp\somefile.txt).
Next line of your code: strFile = Dir(strFolder & "*.xlsx") takes this path and adds *.xlsx. In result you would get strFile = Dir("C:\temp\somefile.txt*.xlsx") and that's wrong.
So, change this code:
strFolder = Dir(Range("C7").Value)
strFile = Dir(strFolder & "*.xlsx")
to next one:
strFolder = Range("C7").Value
strFile = Dir(strFolder & "*.xlsx")
Btw, I'd recommend you to specify sheet for Range("C7") like this: wsDest.Range("C7")
Try this
dim strPath as string
strPath = CurDir + "NameofFile.xls"
I have a bunch of datasets with always the same worksheets.
Now I want to make a different file for each worksheet. I found some code that does just that: http://www.extendoffice.com/documents/excel/628-excel-split-workbook.html#kutools
However, I also only want the first three columns of those worksheets and preferably always starting from row 2.
Could somebody point me in the right direction. E.g. on how to change the code I posted.
Try below code :
Sub Splitbook()
Application.ScreenUpdating = False
Dim myPath As String
Dim rng As Range
Dim sht As Worksheet
Dim lastRow As Long
Dim wkb As Workbook
For Each sht In ThisWorkbook.Sheets
lastRow = sht.Range("A6500").End(xlUp).Row
If lastRow < 2 Then GoTo nextSht
Set rng = sht.Range("A2:C" & lastRow)
If Not rng Is Nothing Then
Set wkb = Workbooks.Add
rng.Copy wkb.Sheets(1).Range("A2")
myPath = filePath(sht.Name)
wkb.SaveAs Filename:=myPath
wkb.Close
Set wkb = Nothing
Set rng = Nothing
End If
nextSht:
Next
Application.ScreenUpdating = True
End Sub
Function filePath(worksheetname As String) As String
Dim fso As Object, MyFolder As String
Set fso = CreateObject("Scripting.FileSystemObject")
MyFolder = ThisWorkbook.Path & "\Reports"
If fso.FolderExists(MyFolder) = False Then
fso.CreateFolder (MyFolder)
End If
MyFolder = MyFolder & "\" & Format(Now(), "MMM_YYYY")
If fso.FolderExists(MyFolder) = False Then
fso.CreateFolder (MyFolder)
End If
filePath = MyFolder & "\" & worksheetname & Format(Now(), "DD-MM-YY hh.mm.ss") & ".xlsx"
Set fso = Nothing
End Function