I'm having trouble with this code. Code loops through a directory of watershed data. On single rate zone watersheds the suffix is _0, on multiple rate watersheds the files are split into subsheds _1, _2, _3, etc. to set the rate different codes.
The multi-sheds need merged back into a single _0 file to then be imported into tax software. All data is on sheet 1 of each workbook. here's the code. It's hanging on on filename = Dir right before the loop.
I'm not seeing why it's hanging on the filename before loop - as I have other macros doing rate code changes, etc all using the same format - and they work.
Sub Merge()
Dim folder As String 'used
Dim path As String 'used
Dim fileName As String
Dim file() As String
Dim Watershed As String
Dim Subshed As Integer
Dim previous As Integer
Dim outputFileName As String
Dim wbOutput As Workbook
Dim wsOutput As Worksheet
Dim wbSource As Workbook
Dim wbTarget As Workbook
Dim wbTemp As Workbook
Dim wsTemp As Worksheet
Dim fileCount As Integer
folder = Year(Now()) & "_Excel\"
'path = "J:\Projects\DekalbCo\Surveyor\Surveyor GIS Data\" & folder
path = "J:\Projects\DekalbCo\Surveyor\Surveyor GIS Data\2024_excel\test\"
' Loop through each file in the folder
fileName = Dir(path & "*.xls")
Debug.Print fileName
'initialize subshed to 0
previous = 0
Do While fileName <> ""
' Extract Watershed and Subshed from the filename
file = Split(fileName, "_")
Watershed = file(0) & "_" & file(1)
Debug.Print Watershed
Subshed = Left(file(2), 1)
Debug.Print Subshed
' Check if Subshed is greater than 0
If Subshed > previous Then
previous = Subshed
' Check if output workbook exists for this prefix, create if not
outputFileName = path & Watershed & "_0.xls"
If Dir(outputFileName) = "" Then
Set wbOutput = Workbooks.Add
wbOutput.SaveAs outputFileName
Set wsOutput = wbOutput.Sheets(1)
isFirstFile = True
Else
Set wbOutput = Workbooks.Open(outputFileName)
Set wsOutput = wbOutput.Sheets(1)
isFirstFile = False
End If
' Open the current file
Set wbTemp = Workbooks.Open(path & fileName)
Set wsTemp = wbTemp.Sheets(1)
' Copy data to the output workbook
If Not isFirstFile Then
' Remove header from the second and subsequent sheets
If wsTemp.UsedRange.Rows.Count > 1 Then
wsTemp.Rows(1).Delete
End If
End If
wsTemp.UsedRange.Copy wsOutput.Cells(wsOutput.Cells(Rows.Count, 1).End(xlUp).Row, 1)
' Close the temporary workbook without saving
wbTemp.Close False
' Close and save the output workbook
wbOutput.Close True
' Increment file count
'fileCount = fileCount + 1
End If
' Get the next file
fileName = Dir
Loop
End Sub
Here's one suggestion for how to manage this (untested):
Option Explicit
Const PATH_ROOT As String = "J:\Projects\DekalbCo\Surveyor\Surveyor GIS Data\2024_excel\test\"
Sub Merge()
Dim dict As Object, f As String, lr As Long, rngCopy As Range, k
Dim Watershed As String, Subshed As Long, wbZero As Workbook, wsZero As Worksheet, wb As Workbook
Set dict = CreateObject("scripting.dictionary")
dict.CompareMode = 1 'case-insensitive
'start by collecting all source files with specific pattern
f = Dir(PATH_ROOT & "*_*_*.xls")
Do While Len(f) > 0
If InStr(f, "_0.xls") = 0 Then 'not collecting "zero" files
dict.Add f, True 'a file we need to process?
End If
f = Dir()
Loop
'loop over files
For Each k In dict
Watershed = GetWatershed(k)
Subshed = GetSubshed(k)
'open source
Set wb = Workbooks.Open(PATH_ROOT & k)
Set rngCopy = wb.Worksheets(1).UsedRange
'open destination and copy content
Set wbZero = ZeroFile(Watershed)
With wbZero.Worksheets(1)
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
If lr = 1 Then
rngCopy.Copy .Cells(lr, 1) 'first data: include headers
Else
rngCopy.Offset(1).Copy .Cells(lr + 1, 1) 'skip headers
End If
End With
wb.Close savechanges:=False
wbZero.Close savechanges:=True
Next k
End Sub
'handle parameter extraction
Function GetWatershed(fName) As String
Dim arr
arr = Split(fName, "_")
GetWatershed = arr(0) & "_" & arr(1)
End Function
Function GetSubshed(fName) As Long
Dim arr
arr = Split(fName, "_")
GetSubshed = CLng(Replace(arr(2), ".xls", ""))
End Function
'construct file name
Function FileName(Watershed As String, Subshed As Long) As String
FileName = Watershed & "_" & Subshed & ".xls"
End Function
'return a reference to the (opened) "zero" file for a given watershed
Function ZeroFile(Watershed As String) As Workbook
Dim fName As String
fName = FileName(Watershed, 0)
If Len(Dir(PATH_ROOT & fName, vbNormal)) = 0 Then
Set ZeroFile = Workbooks.Add(xlWBATWorksheet) 'has one worksheet
ZeroFile.SaveAs PATH_ROOT & fName
Else
Set ZeroFile = Workbooks.Open(PATH_ROOT & fName)
End If
End Function
Open question of whether the copy/paste order is important in each summary file.