(서식은 괜찮았으면 좋겠습니다. 폰으로 하는 작업이라 말씀드리기 어렵네요.)
그래서 현장 직원으로부터 얻은 데이터 정리 프로세스를 자동화하기 위해 VBA를 만들려고 합니다. 아래의 모든 기능은 완벽하게 작동하지만 마지막에 .txt를 내보내는 위치에 추가하려고 합니다.그리고원본 파일을 가져온 것과 동일한 경로에 파일의 매크로 사용 통합 문서를 저장합니다( \\Atlas\Projects\[fileName]\Survey\In\). 문제는 내보내고 저장하기 위해 코드를 어떻게 변경하려고 했는지가 중요하지 않고 "파일 경로가 존재하지 않습니다" 오류 또는 개체 오류가 계속 발생한다는 것입니다. 이유를 알 수 없고 여기 누군가가 통찰력을 줄 수 있을 것이라고 생각했습니다. 제안이나 안내에 미리 감사드립니다!
추가하려는 코드 내보내기/저장
참고: 추가할 때 Dim을 원래 위치에 그대로 두고 작동 코드의 나머지 Dim과 함께 위로 이동해 보았습니다.
' 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
추가하려는 기능 코드
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