0

(Hope the formatting is okay. I’m doing this on my phone, so it’s hard to tell.)

So, I’m trying to create some VBA to automate the clean up process of data I get from my field crews. Everything below works perfectly, but I’m trying to add on it to make it where, at the very end, it exports a .txt and saves a macro-enabled workbook of the file to the same path the original files were imported from (\\Atlas\Projects\[fileName]\Survey\In\). The issue is, it hasn’t mattered how I’ve tried to change up the code for exporting and saving, I keep getting “file path doesn’t exist” errors or Object errors. I can’t figure out why and thought maybe someone here could give some insight. Thanks in advance for any suggestions or guidance!

Export/Save Code I’m Trying to Add

Note: When I add it, I’ve tried both leaving the Dims where they are and also tried moving them up with the rest of the Dims in the functioning code.

' Export CleanDataTBL to a comma-delimited .txt file
Dim exportFileName As String
Dim exportFilePath As String

exportFileName = fileName & "-AllPoint-" & Format(Date, "YYYYMMDD") & "-DeDuped.txt"
exportFilePath = "\\Atlas\Projects\" & fileName & "\Survey\In\" & exportFileName

tbl.DataBodyRange.Copy
Workbooks.Add(1).Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs exportFilePath, FileFormat:=xlText, CreateBackup:=False
Application.DisplayAlerts = True
ActiveWorkbook.Close False

' Save macro-enabled workbook with the same name format but with "-Workbook" suffix
Dim workbookFileName As String
Dim workbookFilePath As String

workbookFileName = fileName & "-AllPoint-" & Format(Date, "YYYYMMDD") & "-DeDuped-Workbook.xlsm"
workbookFilePath = "\\Atlas\Projects\" & fileName & "\Survey\In\" & workbookFileName

ThisWorkbook.SaveAs workbookFilePath, FileFormat:=52 ' xlOpenXMLWorkbookMacroEnabled

Functioning Code I’m Trying to Add TO

Sub RawFDCleanup()
    Dim RawDataWS As Worksheet
    Dim fileName As String
    Dim filePath As String
    Dim fileContent As String
    Dim fileLine As Variant
    Dim lastRow As Long
    Dim tbl As ListObject
    Dim rng As Range
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim pointColRaw As Range
    Dim cellRaw As Range
    Dim duplicateRaw As Boolean
    Dim CleanDataWS As Worksheet
    Dim cleanDataTbl As ListObject
    Dim rowCount As Long
    Dim colCount As Long
    Dim l As Long
    Dim m As Long
    Dim deleteRow As Boolean
    Dim pointColClean As Range
    Dim cellClean As Range
    Dim duplicateClean As Boolean
    
    ' Create RawDataWS worksheet
    Set RawDataWS = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    RawDataWS.Name = "RawDataWS"
    
    ' Add headers
    With RawDataWS
        .Cells(1, 1).Value = "Point #"
        .Cells(1, 2).Value = "Northing"
        .Cells(1, 3).Value = "Easting"
        .Cells(1, 4).Value = "Elevation"
        .Cells(1, 5).Value = "Description"
    End With
    
    ' Prompt user for file name
    fileName = InputBox("Enter a job # to search for on \\Atlas\Projects\:")
    
    ' Construct file path
    filePath = "\\Atlas\Projects\" & fileName & "\Survey\In\"
    
    ' Check if directory exists
    If Dir(filePath, vbDirectory) <> "" Then
        ' Loop through all .txt files in the directory
        fileName = Dir(filePath & "*.txt")
        
        ' Initialize lastRow to the first available row
        lastRow = 2 ' Start from row 2 to skip headers
        
        Do While fileName <> ""
            ' Open file and read content
            Open filePath & fileName For Input As #1
            Do Until EOF(1)
                Line Input #1, fileLine
                fileContent = fileContent & fileLine & vbCrLf
            Loop
            Close #1
            
            ' Split content by newline and paste into worksheet
            Dim lines() As String
            lines = Split(fileContent, vbCrLf)
            For i = 0 To UBound(lines)
                Dim rowData() As String
                rowData = Split(lines(i), ",")
                ' Convert text-formatted values to numbers
                RawDataWS.Cells(lastRow, 1).Resize(1, 5).Value = rowData
                ' Convert text to numbers in the Point #, Northing, Easting, and Elevation columns
                RawDataWS.Cells(lastRow, 1).Resize(1, 4).Value = RawDataWS.Cells(lastRow, 1).Resize(1, 4).Value
                lastRow = lastRow + 1
            Next i
            
            ' Reset file content for next file
            fileContent = ""
            
            ' Move to the next file
            fileName = Dir
        Loop
    Else
        MsgBox "Directory not found."
    End If
    
    ' After importing all data, format as a table
    If lastRow > 2 Then
        ' Convert the data to a table
        Set tbl = RawDataWS.ListObjects.Add(xlSrcRange, RawDataWS.Range("A1").Resize(lastRow - 1, 5), , xlYes)
        tbl.Name = "RawDataTBL"
        tbl.TableStyle = "TableStyleMedium4"
        
        ' Format Northing, Easting, and Elevation columns to three decimal places
        With tbl.ListColumns("Northing").DataBodyRange
            .NumberFormat = "0.000"
        End With
        With tbl.ListColumns("Easting").DataBodyRange
            .NumberFormat = "0.000"
        End With
        With tbl.ListColumns("Elevation").DataBodyRange
            .NumberFormat = "0.000"
        End With
        
        ' Set the width of columns A to D to specified values
        RawDataWS.Columns("A").ColumnWidth = 8
        RawDataWS.Columns("B:C").ColumnWidth = 14
        RawDataWS.Columns("D").ColumnWidth = 10
        
        ' Autofit column E to the width of its content
        RawDataWS.Columns("E").AutoFit
        
        ' Align text of Columns B-D to center
        RawDataWS.Columns("B:D").HorizontalAlignment = xlCenter
        
        ' Turn off filter button
        tbl.ShowAutoFilter = False
        
        ' Remove blank rows from the table
        Set rng = tbl.DataBodyRange
        For i = rng.Rows.Count To 1 Step -1
            If Application.WorksheetFunction.CountA(rng.Rows(i)) = 0 Then
                rng.Rows(i).Delete
            End If
        Next i
    End If
    
    ' Check for duplicates in RawDataTBL
    
    Set RawDataWS = ThisWorkbook.Worksheets("RawDataWS")
    Set tbl = RawDataWS.ListObjects("RawDataTBL")
    Set pointColRaw = tbl.ListColumns("Point #").DataBodyRange
    
    For Each cellRaw In pointColRaw
        If WorksheetFunction.CountIf(pointColRaw, cellRaw.Value) > 1 Then
            If WorksheetFunction.CountIf(tbl.ListColumns("Point #").DataBodyRange, cellRaw.Value) = 1 Then
                tbl.Range.Rows(cellRaw.Row).Delete
            Else
                tbl.Range.Rows(cellRaw.Row).Interior.Color = RGB(255, 192, 192)
                tbl.Range.Rows(cellRaw.Row).Font.Color = RGB(192, 0, 0)
            End If
            duplicateRaw = True
        End If
    Next cellRaw
    
    If Not duplicateRaw Then
        MsgBox "No duplicate Point #’s were found in the field data.", vbInformation
    End If
    
    ' Duplicate RawDataWS worksheet
    RawDataWS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
    ' Rename the duplicated worksheet
    ActiveSheet.Name = "CleanDataWS"
    
    ' Explicitly set CleanDataWS worksheet
    
    Set CleanDataWS = ThisWorkbook.Worksheets("CleanDataWS")
    
    ' Rename the table on CleanDataWS worksheet
    
    On Error Resume Next
    Set cleanDataTbl = CleanDataWS.ListObjects("RawDataTBL3")
    On Error GoTo 0
    
    If Not cleanDataTbl Is Nothing Then
        cleanDataTbl.Name = "CleanDataTBL"
    Else
        MsgBox "No table found on CleanDataWS worksheet.", vbExclamation
    End If
    
    ' Change table style of CleanDataTBL
    If Not cleanDataTbl Is Nothing Then
        cleanDataTbl.TableStyle = "TableStyleMedium3"
    Else
        MsgBox "No table found on CleanDataWS worksheet.", vbExclamation
    End If

    ' Analyze and remove duplicate rows in CleanDataTBL

    If Not cleanDataTbl Is Nothing Then
        rowCount = cleanDataTbl.ListRows.Count
        colCount = cleanDataTbl.ListColumns.Count
    
        ' Iterate through each row
        For l = rowCount To 2 Step -1
            deleteRow = False
            ' Iterate through each previous row to compare
            For m = l - 1 To 1 Step -1
                ' Compare each cell of the current row with the previous row
                Dim rowMatch As Boolean
                rowMatch = True
                For n = 1 To colCount
                    If cleanDataTbl.DataBodyRange.Cells(l, n).Value <> cleanDataTbl.DataBodyRange.Cells(m, n).Value Then
                        rowMatch = False
                        Exit For ' Exit loop if any cell is different
                    End If
                Next n
                If rowMatch Then
                    deleteRow = True
                    Exit For ' Exit loop if duplicate row found
                End If
            Next m
        
            ' If duplicate row found, delete the current row
            If deleteRow Then
                cleanDataTbl.ListRows(l).Delete
            End If
        Next l
    Else
        MsgBox "No table found on CleanDataWS worksheet.", vbExclamation
    End If
    
    ' Analyze Point # column for remaining duplicates and apply formatting

    Set CleanDataWS = ThisWorkbook.Worksheets("CleanDataWS")
    Set tbl = CleanDataWS.ListObjects("CleanDataTBL")
    Set pointColClean = tbl.ListColumns("Point #").DataBodyRange
    
    For Each cellClean In pointColClean
        If WorksheetFunction.CountIf(pointColClean, cellClean.Value) > 1 Then
            tbl.Range.Rows(cellClean.Row).Interior.Color = RGB(255, 192, 192)
            tbl.Range.Rows(cellClean.Row).Font.Color = RGB(192, 0, 0)
            duplicateClean = True
        Else
            tbl.Range.Rows(cellClean.Row).Interior.ColorIndex = xlNone
            tbl.Range.Rows(cellClean.Row).Font.Color = RGB(0, 0, 0)
        End If
    Next cellClean
    
    If Not duplicateClean Then
        MsgBox "No duplicate Point #’s were found in the field data.", vbInformation
    End If
End Sub
1
  • I think your SaveAs needs to have the Filename:= before workbookFilePath possibly without the extension (it seems to be a part of your fileFormat parameter.
    – gns100
    Commented Feb 26 at 17:28

0

You must log in to answer this question.

Browse other questions tagged .