I am a bit stuck with finishing the script below.
I got to this point and it does the basic thing I need it to do but it does need a bit of tweaking to get perfect.
It does the following: 1-pickup and prep master output file; 2- open each file in folder 'xls' and copy data from the designated sheet at the end of the master output file; 3-final edit of the master file; 4-save master file with name based on the input archives.
Where I need help is and was unable to fix up is: I want the script to cycle through subfolders in 'xls' folder and create a single master for each subfolder in 'xls' collecting data from files in that subfolder and name it after subfolder.
I understand I need another loop for subfolders but I am not really good with dirs in vba. Would this require a major overhaul?
Sub Joiner()
'Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim FileNAME As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim DayVar As String
Dim RangeVar As Variant
Dim LastRow As Long
Dim Targetsh As Worksheet
Dim RecordsCount As Long
' set master workbook
Workbooks.Open FileNAME:="C:\TA\output\Master Template.xlsx"
Set Masterwb = Workbooks("Master Template.xlsx")
Set Targetsh = Masterwb.Sheets("Data")
With ActiveWorkbook.Sheets("Data")
.Range("A1").FormulaR1C1 = "SysTime"
.Range("B1").FormulaR1C1 = "Seq#"
.Range("C1").FormulaR1C1 = "A1"
.Range("D1").FormulaR1C1 = "F2"
.Range("E1").FormulaR1C1 = "F3"
.Range("F1").FormulaR1C1 = "T4"
.Range("G1").FormulaR1C1 = "T5"
.Range("H1").FormulaR1C1 = "T6"
.Range("I1").FormulaR1C1 = "T7"
.Range("J1").FormulaR1C1 = "T8"
.Range("K1").FormulaR1C1 = "A9"
.Range("A1:K1").Font.Bold = True
.Range("A1:K1").Interior.ColorIndex = 19
.Range("L1").FormulaR1C1 = "Date"
.Range("M1").FormulaR1C1 = "Date/Seq#"
End With
folderPath = "C:\TA\xls\" 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
Application.ScreenUpdating = False
FileNAME = Dir(folderPath & "*.xls*")
Do While FileNAME <> ""
Set wb = Workbooks.Open(folderPath & FileNAME)
'DayVar = Left(Right(wb.Name, 13), 8)
LastRow = wb.Sheets("Cleaned").Range("A1").End(xlDown).Row
RangeVar = wb.Sheets("Cleaned").Range("A2:K" & LastRow)
Targetsh.Range("A" & Rows.Count).End(xlUp)(2).Resize(UBound(RangeVar, 1), UBound(RangeVar, 2)) = RangeVar
wb.Close False
Exit_Loop:
Set wb = Nothing
FileNAME = Dir
Loop
Application.ScreenUpdating = True
With Masterwb.Sheets("Data")
.Range(Range("A2"), Range("A2").End(xlDown)).NumberFormat = "dd/mm/yyyy hh:mm:ss"
End With
LastRow = ActiveWorkbook.Sheets("Data").Range("A1").End(xlDown).Row
With ActiveWorkbook.Sheets("Data")
.Range("L2").FormulaR1C1 = "=INT(C1)"
.Range("M2").FormulaR1C1 = "=C12&""-""&C2"
End With
Range("L2").AutoFill Destination:=Range("L2" & ":L" & LastRow)
With ActiveSheet
.Columns("L:L").Cells = .Columns("L:L").Cells.Value
End With
Range("M2").AutoFill Destination:=Range("M2" & ":M" & LastRow)
With ActiveSheet
.Columns("M:M").Cells = .Columns("M:M").Cells.Value
End With
With Masterwb.Sheets("Data")
.Range(Range("L2"), Range("L2").End(xlDown)).NumberFormat = "dd/mm/yyyy"
End With
'Name the master output based on id
Dim FirstName As String
Dim InterName As String
Dim FinalName As String
Dim FilePath As String
FirstName = Dir("C:TA\Input\*.cab", vbNormal)
InterName = "Master Template " & Right(Left(FirstName, 12), 4)
'MsgBox FirstName
'MsgBox InterName
FilePath = "C:\TA\output"
ActiveWorkbook.SaveAs FileNAME:=FilePath & "\" & InterName & ".xlsx", _
FileFormat:=51, CreateBackup:=False
'
End Sub
Thank you for any advice.
With this code you can list excel files in a folder and subfolders
Sub ListSubfoldersFile() ' only one level subfolders
arow = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
mFolder = "F:\Download\" ' path to change
Set mainFolder = objFSO.GetFolder(mFolder)
StrFile = Dir(mFolder & "*.xls*")
Do While Len(StrFile) > 0
Cells(arow, 1).Value = mFolder & StrFile
arow = arow + 1
StrFile = Dir
Loop
For Each mySubFolder In mainFolder.subfolders
StrFile = Dir(mySubFolder & "\*.xls*")
Do While Len(StrFile) > 0
Cells(arow, 1).Value = mySubFolder & "\" & StrFile
arow = arow + 1
StrFile = Dir
Loop
Next
End Sub
Thank you Patel!
I used your solution to complement my current vba snippet.
It may be a bit clunky but it does what I need it to do.
Thank you.
Posting a solution below for the benefit of the community.
Sub MassJoiner()
'this is a version of joiner with subfolders
'Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim FileNAME As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim DayVar As String
Dim RangeVar As Variant
Dim LastRow As Long
Dim Targetsh As Worksheet
Dim RecordsCount As Long
Dim StrFile As String
Dim mFolder As String
Dim BatchCount As Long
Dim ID As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
mFolder = "D:\TA\TEST\" ' path to change
Set mainFolder = objFSO.GetFolder(mFolder)
StrFile = Dir(mFolder & "*.xls*")
BatchCount = 0
Workbooks.Open FileNAME:="C:\TA\output\Master Template.xlsx"
For Each mySubFolder In mainFolder.subfolders
StrFile = Dir(mySubFolder & "\*.xls*")
Do While Len(StrFile) > 0
Set Masterwb = Workbooks("Master Template.xlsx")
Set Targetsh = Masterwb.Sheets("Data")
With ActiveWorkbook.Sheets("Data")
.Range("A1").FormulaR1C1 = "SysTime"
.Range("B1").FormulaR1C1 = "Seq#"
.Range("C1").FormulaR1C1 = "A1"
.Range("D1").FormulaR1C1 = "F2"
.Range("E1").FormulaR1C1 = "F3"
.Range("F1").FormulaR1C1 = "T4"
.Range("G1").FormulaR1C1 = "T5"
.Range("H1").FormulaR1C1 = "T6"
.Range("I1").FormulaR1C1 = "T7"
.Range("J1").FormulaR1C1 = "T8"
.Range("K1").FormulaR1C1 = "A9"
.Range("A1:K1").Font.Bold = True
.Range("A1:K1").Interior.ColorIndex = 19
.Range("L1").FormulaR1C1 = "Date"
.Range("M1").FormulaR1C1 = "Date/Seq# pair"
End With
'FileNAME = Dir(folderPath & "*.xls*")
'Do While FileNAME <> ""
Set wb = Workbooks.Open(mySubFolder & "\" & StrFile)
'DayVar = Left(Right(wb.Name, 13), 8)
LastRow = wb.Sheets("Cleaned").Range("A1").End(xlDown).Row
RangeVar = wb.Sheets("Cleaned").Range("A2:K" & LastRow)
Targetsh.Range("A" & Rows.Count).End(xlUp)(2).Resize(UBound(RangeVar, 1), UBound(RangeVar, 2)) = RangeVar
wb.Close False
'Exit_Loop:
' Set wb = Nothing
' FileNAME = Dir
'Loop
StrFile = Dir
Loop
With Masterwb.Sheets("Data")
.Range(Range("A2"), Range("A2").End(xlDown)).NumberFormat = "dd/mm/yyyy hh:mm:ss"
End With
LastRow = ActiveWorkbook.Sheets("Data").Range("A1").End(xlDown).Row
With ActiveWorkbook.Sheets("Data")
.Range("M2").FormulaR1C1 = "Date/Seq# pair"
.Range("m2").FormulaR1C1 = "=C12&""-""&C2"
End With
Range("L2").AutoFill Destination:=Range("L2" & ":L" & LastRow)
With ActiveSheet
.Columns("L:L").Cells = .Columns("L:L").Cells.Value
End With
Range("M2").AutoFill Destination:=Range("M2" & ":M" & LastRow)
With ActiveSheet
.Columns("M:M").Cells = .Columns("M:M").Cells.Value
End With
With Masterwb.Sheets("Data")
.Range(Range("l2"), Range("l2").End(xlDown)).NumberFormat = "dd/mm/yyyy"
End With
'Name the master output based on job id
Dim FirstName As String
Dim InterName As String
Dim FinalName As String
Dim FilePath As String
FirstName = mySubFolder
InterName = "Master Template " & Right(FirstName, 4)
ID = Right(FirstName, 4)
'MsgBox FirstName
'MsgBox InterName
FilePath = "C:\TA\output"
ActiveWorkbook.SaveAs FileNAME:=FilePath & "\" & InterName & ".xlsx", _
FileFormat:=51, CreateBackup:=False
ActiveWorkbook.Close False
BatchCount = BatchCount + 1
Application.Speech.Speak "Batch job" & BatchCount & "finalized. ID" & ID
Workbooks.Open FileNAME:="C:\output\Master Template.xlsx"
Next
Application.ScreenUpdating = True
End Sub
Related
I have multiple workbooks each having the same sheet. I want to Copy the sheet's value to the master book.
I want to copy the selected range value of each Workbook to the single row of the new workbook.
Also, how can I retrieve the options button caption from the source workbook? Where Option buttons are ActiveX and linked cells.
If the options button is checked, copy the options button caption value to the destination cell.
Also I wish to add yyyy , mm,dd values in Date format (yyyy/mm/dd)
Sub test1()
Dim Wsh As New IWshRuntimeLibrary.WshShell
Dim result As WshExec
Dim fileData() As String
Dim path As String
Dim cmd As String
path = ThisWorkbook.path & "\Book1"
cmd = "dir" & path & "/Test"
Set result = Wsh.Exec("%ComSpec% /c" & cmd)
Do While result.Status = 0
DoEvents
Loop
fileData = Split(result.StdOut.ReadAll, vbCrLf)
Dim i As Long
i = 4
For Each strData In fileData
Cells(i, 2).Value = strData
If Cells(i, 2).Value <> "" Then
Cells(i, 3).Value = "='" & path & "\[" & strData & "]sheet1'!F1" '
Cells(i, 4).Value = "='" & path & "\[" & strData & "]sheet1'!C4" '
End If
i = i + 1
Next
End Sub
Retrieve Data From Closed Workbooks 2
Sub RetrieveDataFromClosedWorkbooks2()
Const SOURCE_SUBFOLDER_NAME As String = "Book1"
Const SOURCE_FILE_PATTERN As String = "*.xlsx"
Const SOURCE_WORKSHEET_NAME As String = "Sheet1"
Const SOURCE_CELL_ADDRESSES_LIST As String = "F1,C4"
Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "B4"
Dim dwb As Workbook: Set dwb = ThisWorkbook
Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
Dim dCell As Range: Set dCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
Dim pSep As String: pSep = Application.PathSeparator
Dim sFolderPath As String
sFolderPath = dwb.Path & pSep & SOURCE_SUBFOLDER_NAME
If Right(sFolderPath, 1) <> pSep Then sFolderPath = sFolderPath & pSep
Dim sFileNames() As String
sFileNames = FileNamesToArray(sFolderPath, SOURCE_FILE_PATTERN)
If UBound(sFileNames) = -1 Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
Dim sAddresses() As String
sAddresses = Split(SOURCE_CELL_ADDRESSES_LIST, ",")
Dim sf As Long
Dim sa As Long
Dim dFormula As String
For sf = 0 To UBound(sFileNames)
dCell.Offset(sf).Value = sFileNames(sf) ' source file name
For sa = 0 To UBound(sAddresses)
dFormula = "='" & sFolderPath & "[" & sFileNames(sf) _
& "]" & SOURCE_WORKSHEET_NAME & "'!" & sAddresses(sa)
'Debug.Print dFormula
With dCell.Offset(sf, sa + 1)
'Debug.Print .Address, sf, sFileNames(sf), sa, sAddresses(sa)
.Formula = dFormula
'.Value = .Value ' to keep only values
End With
Next sa
Next sf
MsgBox "Data retrieved.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the names of all files of a folder in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function FileNamesToArray( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "*.*") _
As String()
Const DirSwitches As String = "/b/a-d"
Dim pSep As String: pSep = Application.PathSeparator
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
ExecString = "%comspec% /c Dir """ _
& FolderPath & FilePattern & """ " & DirSwitches
Dim pString As String
pString = CreateObject("WScript.Shell").Exec(ExecString).StdOut.ReadAll
If Len(pString) = 0 Then ' multiple issues: no file, invalid input(s)
FileNamesToArray = Split("") ' ensure string array: 'LB = 0, UB = -1'
Else
pString = Left(pString, Len(pString) - 2) ' remove trailing 'vbCrLf'
FileNamesToArray = Split(pString, vbCrLf)
End If
End Function
here is a screenshot of my dataI have a set of measurements. Their related timestamps are in text format, like this: 12/23/2021 2:00:00 AM. My goal is to calculate a daily average of my measurements. I have this code but it stops in consolidate step. Does anyone know how to fix it:
Sub consolidate()
Dim folderPath As String
Dim filename As String
Dim wkb As Workbook
folderPath = "F:\analysis\12hourly\"
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
filename = Dir(folderPath & "*.xls")
Do While filename <> ""
Application.ScreenUpdating = False
Set wkb = Workbooks.Open(folderPath & filename) 'Open all files in directory
wkb.Activate
Rows("1:1").Select
Selection.Delete Shift:=xlUp 'Delete first row
Dim Lastrow As Integer
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
Lastrow2 = Range("B" & Rows.Count).End(xlUp).Row
Dim D, E
D = Mid("A3:Lastrow", 1, 10) 'Remove hour & minute
Dim wkbr As Workbook
Set wkbr = Workbooks.Add
Dim rng As Range
Set rng = wkrb.Sheets("Sheet1").Cells(1, 1)
wkb.Activate
Dim ConsolidateRangeArray As Variant 'Daily average
ConsolidateRangeArray = Array(D, "B3:Lastrow2")
rng.consolidate _
Sources:=ConsolidateRangeArray, _
Function:=xlAverage, TopRow:=False, LeftColumn:=True, CreateLinks:=False
Dim wkbpath As String
Dim wkbname As String
wkb.Activate
wkbpath = "F:\analysis\2daily\" 'Save result in folder daily
wkbname = ActiveWorkbook.Name
ActiveWorkbook.SaveAs filename:= _
wkbpath & wkbname & ".xlsx", FileFormat:=xlCSVUTF8 _
, CreateBackup:=False
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = False
filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
I inherited VBA code that has not worked since my work updated our version of Excel.
The original code looped through all Excel files in a specific folder.
If data in specific cells was blank or a 0, would rename the whole workbook so I would know what files to delete after the fact.
This is the original code. I don't need it to do all of this anymore.
This is part one:
Sub AllFilesWeekly()
Dim folderPath As String
Dim filename As String
Dim wb As Workbook
folderPath = "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\" 'change to suit
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & filename)
'Call a subroutine here to operate on the just-opened workbook
Call getmetrics
On Error Resume Next
If Not ActiveWorkbook.Name Like "Audit Hub Report Distribution*" Then
ActiveWorkbook.Close
End If
filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
The second part:
Sub getmetrics()
Dim cell As Range
Dim procstring As String, wbname As String
'Dim OQAYTD As String
Dim OQAMTD As String
Dim ORLYTD As String
Dim ORLMTD As String
Dim DR As String
Dim Audits As Long
Dim permonth As String, peryear As String, permonthrl As String, peryearrl As String
Dim RS As Worksheet, AD As Worksheet, QD As Worksheet, ws As Worksheet, YN As Boolean
For Each ws In Worksheets
If ws.Name = "Audit Detail" Then
YN = True
End If
Next ws
If YN = True Then
ActiveWorkbook.Sheets(2).Name = ("Rep Summary")
Set RS = ActiveWorkbook.Sheets("Rep Summary")
Set AD = ActiveWorkbook.Sheets("Audit Detail")
Set QD = ActiveWorkbook.Sheets("Question Detail")
With Sheets("Process Summary")
For Each cell In Range(Range("A3"), Range("A9999").End(xlUp))
If cell.Value = "Record Level YTD" Then
ORLYTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "YTD Quality Average" Then
OQAYTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Record Level Quality Average" Then
ORLMTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Quality Average" Then
OQAMTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Audits" Then
Audits = Range(cell.Address).Offset(0, 1).Value
End If
End If
End If
End If
End If
Next cell
End With
wbname = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
peryear = VBA.Format(OQAYTD, "Percent")
permonth = VBA.Format(OQAMTD, "Percent")
peryearrl = VBA.Format(ORLYTD, "Percent")
permonthrl = VBA.Format(ORLMTD, "Percent")
DR = Right(Sheets("Process Summary").Range("A2").Value, Len(Sheets("Process
Summary").Range("A2").Value) - 12)
RS.Range(RS.Range("A1"), RS.Range("IV1").End(xlToLeft)).AutoFilter
RS.Range(RS.Range("A1"), RS.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
AD.Range(AD.Range("A1"), AD.Range("IV1").End(xlToLeft)).AutoFilter
AD.Range(AD.Range("A1"), AD.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
QD.Range(QD.Range("A1"), QD.Range("IV1").End(xlToLeft)).AutoFilter
QD.Range(QD.Range("A1"), QD.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
Application.DisplayAlerts = False
procstring = wbname & "|" & permonth & "|" & Audits & "|" & peryear & "|" & permonthrl & "|" &
peryearrl & "|" & DR ' & "|" & Users
Debug.Print procstring
Else
Application.DisplayAlerts = False
Dim AWN As String
AWN = ActiveWorkbook.FullName
Debug.Print "Not Audited: " & ActiveWorkbook.Name
ActiveWorkbook.SaveAs "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\Delete -" & Second(Now)
Kill AWN
ActiveWorkbook.Close savechanges:=True
Application.DisplayAlerts = True
End If
End Sub
All I need to do is look at cell D3 on the "Process Summary" tab.
If the value in that space is "0.00%", rename the workbook to delete and loop on until all workbooks are looked at.
I do not need to screen print all the extra numbers any more.
Build a Collection of filenames that match the criteria and then use it to rename the files.
Option Explicit
Sub AllFilesWeekly()
Dim folderPath As String, filename As String
Dim wb As Workbook, ws As Worksheet
Dim col As Collection, n As Long
Set col = New Collection
folderPath = "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\" 'change to suit
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
' scan folder
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
Set wb = Workbooks.Open(folderPath & filename, True, True) ' update links, readonly
For Each ws In wb.Sheets
If ws.Name = "Process Summary" Then
If Format(ws.Range("D3"), "0.00%") = "0.00%" Then
col.Add wb.Name
End If
End If
Next
wb.Close
n = n + 1
filename = Dir
Loop
' result
MsgBox "Files scanned = " & n & vbCrLf & _
"To delete = " & col.Count, vbInformation, folderPath
' rename
If col.Count > 0 Then
If MsgBox("Continue to rename ?", vbYesNo) = vbYes Then
For n = 1 To col.Count
Name folderPath & col(n) As folderPath & "delete_" & col(n)
Next
MsgBox "Rename done"
End If
End If
End Sub
I have 2 questions with my coding. Please bear with me since I'm not an expert on this.
Ws2.range("B6:Y" & lrow1).copy - doesn't seem to work the way I wanted it to be. It copies cells only from B1:Y6 but the intention is to copy cells starting ffrom B6:Y until the last row.
Dir Do while loops only on one file even though I have multiple files on the specified folder path. Thus, creating an infinite loop.
Any idea on what am I doing wrong?
Private Sub conso()
Dim folder As String, consofolder As String
Dim files As String, consofile As String
Dim dateyear As String, team As String
Dim strfile As String, newdate As String
Dim wb1 As Workbook, wb2 As Workbook
Dim lrow1 As Long, lrow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
dateyear = Range("A2").Value
newdate = Format(dateyear, "mmmm yyyy")
team = Range("B2").Value
folder = Range("C2").Value
consofolder = folder & newdate & "\" & team
consofile = "conso "
files = Dir(consofolder & "\*.xlsm")
strfile = consofolder & "\" & consofile & team & " - " & newdate & ".xlsm"
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.AutomationSecurity = msoAutomationSecurityLow
Workbooks.Open Filename:=folder & "\" & "conso conso" & ".xlsm"
Set wb1 = Workbooks("conso conso.xlsm")
wb1.Activate
Set ws1 = wb1.Worksheets("Input")
If Len(Dir(strfile)) = 0 Then
GoTo conso
Else
MsgBox "Conso already in place"
Exit Sub
End If
conso:
Do While files <> ""
Debug.Print files
Workbooks.Open Filename:=consofolder & "\" & files
Set wb2 = Workbooks(files)
Set ws2 = wb2.Worksheets("Input")
With wb2
With Worksheets("Input")
lrow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
End With
ws2.Range("B6:Y" & lrow1).Copy
wb1.Activate
With wb1
With Worksheets("Input")
lrow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
End With
ws1.Range("B" & lrow2).PasteSpecial
wb2.Close
files = Dir(consofolder & "\*.xlsm")
Set wb2 = Nothing
Loop
End Sub
VBA code not looping through the folder of .csv's
The code below is doing the function I need but is not looping and it would be good to add a line to delete the .csv's once copied
Option Explicit
Private Sub SaveAs_Files_in_Folder()
Dim CSVfolder As String, XLSfolder As String
Dim CSVfilename As String, XLSfilename As String
Dim template As String
Dim wb As Workbook
Dim wbm As Workbook 'The template I want the data pasted into
Dim n As Long
CSVfolder = "H:\Case Extracts\input" 'Folder I have the csv's go
XLSfolder = "H:\Case Extracts\output" 'Folder for the xlsx output
If Right(CSVfolder, 1) <> "\" Then CSVfolder = CSVfolder & "\"
If Right(XLSfolder, 1) <> "\" Then XLSfolder = XLSfolder & "\"
n = 0
CSVfilename = Dir(CSVfolder & "*.csv", vbNormal)
template = Dir("H:\Case Extracts\template.xlsx", vbNormal)
While Len(CSVfilename) <> 0
n = n + 1
Set wb = Workbooks.Open(CSVfolder & CSVfilename)
Range("A1:M400").Select
Selection.Copy
Set wbm = Workbooks.Open(template, , , , "Password") 'The template has a password
With wbm
Worksheets("Sheet2").Activate
Sheets("Sheet2").Cells.Select
Range("A1:M400").PasteSpecial
Worksheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select
wbm.SaveAs Filename:=XLSfolder & CSVfilename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
wbm.Close
End With
With wb
.Close False
End With
CSVfilename = Dir()
Wend
End Sub
The code works for the first .csv file I just can't get the loop to keep going through the files. It would also be good to add a line to delete the .csv's once they have been copied
Work with objects. You may want to see How to avoid using Select in Excel VBA. Declare objects for both the csv and template and work with them.
Your DIR is not working because of template = Dir("H:\Case Extracts\template.xlsx", vbNormal) which is right after CSVfilename = Dir(CSVfolder & "*.csv", vbNormal). It is getting reset. Reverse the position as shown below. Move it before the loop as #AhmedAU mentioned.
Copy the range only when you are ready to paste. Excel has an uncanny habit of clearing the clipboard. For example, I am pasting right after I cam copying the range.
Is this what you are trying? (Untested)
Option Explicit
Private Sub SaveAs_Files_in_Folder()
Dim CSVfolder As String, XLSfolder As String
Dim CSVfilename As String, XLSfilename As String
Dim wbTemplate As Workbook, wbCsv As Workbook
Dim wsTemplate As Worksheet, wsCsv As Worksheet
CSVfolder = "H:\Case Extracts\input" '<~~ Csv Folder
XLSfolder = "H:\Case Extracts\output" '<~~ For xlsx output
If Right(CSVfolder, 1) <> "\" Then CSVfolder = CSVfolder & "\"
If Right(XLSfolder, 1) <> "\" Then XLSfolder = XLSfolder & "\"
XLSfilename = Dir("H:\Case Extracts\template.xlsx", vbNormal)
CSVfilename = Dir(CSVfolder & "*.csv")
Do While Len(CSVfilename) > 0
'~~> Open Csv File
Set wbCsv = Workbooks.Open(CSVfolder & CSVfilename)
Set wsCsv = wbCsv.Sheets(1)
'~~> Open Template file
Set wbTemplate = Workbooks.Open(XLSfolder & XLSfilename, , , , "Password")
'~~> Change this to relevant sheet
Set wsTemplate = wbTemplate.Sheets("Sheet1")
'~~> Copy and paste
wsCsv.Range("A1:M400").Copy
wsTemplate.Range("A1").PasteSpecial xlPasteValues
'~~> Save file
wbTemplate.SaveAs Filename:=XLSfolder & CSVfilename & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
'~~> Close files
wbTemplate.Close (False)
wbCsv.Close (False)
'~~> Get next file
CSVfilename = Dir
Loop
'~~> Clear clipboard
Application.CutCopyMode = False
End Sub
I think must be something like this, adapted to very fast looping through huge of csvs files
reference “Microsoft Scripting Runtime” (Add using
Tools->References from the VB menu)
Sub SaveAs_Files_in_Folder()
Dim myDict As Dictionary, wb As Workbook, eachLineArr As Variant
Set myDict = CreateObject("Scripting.Dictionary")
CSVfolder = "H:\Case Extracts\input\"
XLSfolder = "H:\Case Extracts\output\"
Template = ThisWorkbook.path & "\template.xlsx"
fileMask = "*.csv"
csvSeparator = ";"
csvLineBreaks = vbLf ' or vbCrLf
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlManual
'.Visible = False ' uncomment to hide templates flashing
End With
LookupName = CSVfolder & fileMask
Results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & LookupName & Chr(34) & " /S /B /A:-D").StdOut.ReadAll
filesList = Split(Results, vbCrLf)
For fileNr = LBound(filesList) To UBound(filesList) - 1
csvLinesArr = Split(GetCsvFData(filesList(fileNr)), csvLineBreaks) ' read each csv to array
ArrSize = UBound(Split(csvLinesArr(lineNr), csvSeparator))
For lineNr = LBound(csvLinesArr) To UBound(csvLinesArr)
If csvLinesArr(lineNr) <> "" Then
eachLineArr = Split(csvLinesArr(lineNr), csvSeparator) ' read each line to array
ReDim Preserve eachLineArr(ArrSize) ' to set first line columns count to whoole array size
myDict.Add Dir(filesList(fileNr)) & lineNr, eachLineArr ' put all lines into dictionary object
End If
Next lineNr
Set wb = Workbooks.Open(Template, , , , "Password")
wb.Worksheets("Sheet1").[a1].Resize(myDict.Count, ArrSize) = TransposeArrays1D(myDict.Items)
Set fso = CreateObject("Scripting.FileSystemObject")
csvName = fso.GetBaseName(filesList(fileNr))
Set fso = nothing
wb.SaveAs FileName:=XLSfolder & csvName & ".xlsx"
wb.Close
Set wb = Nothing
Next fileNr
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = xlManual
.Visible = True
End With
End Sub
Function GetCsvFData(ByVal filePath As String) As Variant
Dim MyData As String, strData() As String
Open filePath For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
GetCsvFData = MyData
End Function
Function TransposeArrays1D(ByVal arr As Variant) As Variant
Dim tempArray As Variant
ReDim tempArray(LBound(arr, 1) To UBound(arr, 1), LBound(arr(0)) To UBound(arr(0)))
For y = LBound(arr, 1) To UBound(arr, 1)
For x = LBound(arr(0)) To UBound(arr(0))
tempArray(y, x) = arr(y)(x)
Next x
Next y
TransposeArrays1D = tempArray
End Function