Я создал код VBA, который проходит через файл .txt (через запятую), выполняет некоторые вычисления ( Работает нормально ), а затем реорганизует данные (добавляет несколько заголовков и перемещает вседанные на одну строку сбрасывают ненужные данные, не работает в последней строке ) и выплевывают новый файл .csv. Я думаю, что это связано с тем, что я ударил все на один ряд.
Вот вышеупомянутый код:
Private Sub Workbook_Open()
Sheets("Sheet1").Cells.ClearContents
Application.Visible = False
'---------------------------------------------------------------------------------------
'Choose and open the .TXT file for conversion
Dim answer As Integer
answer = MsgBox("Do you want to process a .TXT file for use in InfoSWMM?", vbYesNo + vbQuestion, "Select .TXT File")
If answer = vbNo Then
Application.Visible = True
Exit Sub
End If
Dim Ret
Ret = Application.GetOpenFilename("Text Files (*.txt),*.txt")
If Ret <> False Then
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & Ret, Destination:=Range("$A$1") _
)
.Name = "Sample"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End If
'---------------------------------------------------------------------------------------
'Do data conversion
Dim CountThem As Integer
Dim CountIt2 As Integer
Dim CountIt As Integer
Dim row As Integer
Dim col As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim ant As Double
Dim tester(3) As Double
Dim col_test As Integer
Dim size_test As Integer
Dim rim As Double
Dim Diff2Ele As Double
Dim ResultTxt As String
Dim DiamResultTxt As String
Dim DiamResult As Double
Dim CorrectedDiamResult As Double
Dim Result As Double
Dim MeasDiff As Double
Dim GetElev As Double
Dim GetDiam As String
Dim GetDiam_Val As Double
Dim SVal As Double
Dim Diam2Ft As Double
CountIt = 1
CountIt2 = 1
For row = 1 To ActiveSheet.UsedRange.Rows.Count
If IsEmpty(ActiveSheet.Cells(row, 1).Value) = True Then
Exit For
End If
'Change these values in case feature code library is changed in Carlson, also need to add extra fields
If ActiveSheet.Cells(row, 5).Value = "SD" Or ActiveSheet.Cells(row, 5).Value = "WQ" Or ActiveSheet.Cells(row, 5).Value = "SDCS" Then
col_test = 20
size_test = 19
rim = Val(ActiveSheet.Cells(row, 4).Value) 'Needs val to convert as double
For i = 0 To 3
Result = 0
ResultTxt = Empty
StringLength = Len(Cells(row, col_test))
Str_Length = Len(Cells(row, size_test))
'Gets numbers from string, but ignores 3rd char
DiamResultTxt = Empty
For j = 1 To StringLength
If j = 3 Then GoTo NextIteration 'Skips to next loop on 3rd character, which is an irrelevant number (not one we want)
If IsNumeric(Mid(Cells(row, col_test), j, 1)) = True Or Mid(Cells(row, col_test), j, 1) = "." Then
ResultTxt = ResultTxt & Mid(Cells(row, col_test), j, 1)
End If
NextIteration:
Next j
For j = 1 To Str_Length
If j = 3 Then GoTo nNextIteration 'Skips to next loop on 3rd character, which is an irrelevant number (not one we want)
If IsNumeric(Mid(Cells(row, size_test), j, 1)) = True Then
DiamResultTxt = DiamResultTxt & Mid(Cells(row, size_test), j, 1)
End If
nNextIteration:
Next j
'MsgBox ResultTxt
DiamResult = Val(DiamResultTxt)
CorrectedDiamResult = DiamResult / 12
'MsgBox DiamResult
Result = Val(ResultTxt) 'Needs val to convert as Double
If (InStr(1, ActiveSheet.Cells(row, 34).Value, "TOP") > 0 And InStr(1, ActiveSheet.Cells(row, 34).Value, "PIPE") > 0) Or (InStr(1, ActiveSheet.Cells(row, 36).Value, "TOP") > 0 And InStr(1, ActiveSheet.Cells(row, 36).Value, "PIPE")) Or (InStr(1, ActiveSheet.Cells(row, 38).Value, "TOP") > 0 And InStr(1, ActiveSheet.Cells(row, 38).Value, "PIPE")) Then
tester(i) = Result + CorrectedDiamResult
Else
tester(i) = Result
End If
col_test = col_test + 4
size_test = size_test + 4
Next i
Diff2Ele = WorksheetFunction.Max(tester)
If Diff2Ele = 0 Then
ActiveSheet.Cells(row + 1, 39).Value = "Unable to obtain"
Else
ActiveSheet.Cells(row + 1, 39).Value = rim - Diff2Ele '39 is out of WQ SD and SDCS def. range
End If
End If
'Corrects for top of pipe instances
GetDiam = Empty
If ActiveSheet.Cells(row, 5).Value = "OUTFALL" Then
If InStr(1, ActiveSheet.Cells(row, 18).Value, "TOP") > 0 And InStr(1, ActiveSheet.Cells(row, 18).Value, "PIPE") > 0 Then
GetElev = Val(ActiveSheet.Cells(row, 5).Value)
kLen = Len(Cells(row, 16))
For k = 1 To kLen
If IsNumeric(Mid(Cells(row, 16), k, 1)) = True Or Mid(Cells(row, 16), k, 1) = "." Then
GetDiam = GetDiam & Mid(Cells(row, 16), k, 1)
End If
Next k
GetDiam_Val = Val(GetDiam)
Diam2Ft = GetDiam_Val / 12
ActiveSheet.Cells(row + 1, 39).Value = GetElev - Diam2Ft
Else
ActiveSheet.Cells(row + 1, 39).Value = ActiveSheet.Cells(row, 4).Value
End If
End If
Next row
'---------------------------------------------------------------------------------------
'Prepare sheet re-organization, has to be next step to get altered data from prior process
For row = 1 To ActiveSheet.UsedRange.Rows.Count
If IsEmpty(ActiveSheet.Cells(row, 1).Value) = True Then
Exit For
End If
'ID
ActiveSheet.Cells(row + 1, 44).Value = ActiveSheet.Cells(row, 1).Value
'Description
ActiveSheet.Cells(row + 1, 40).Value = ActiveSheet.Cells(row, 5).Value
'Rim Elevation
If ActiveSheet.Cells(row, 5).Value <> "OUTFALL" Or ActiveSheet.Cells(row, 5).Value <> "DITCH" Then
ActiveSheet.Cells(row + 1, 41).Value = ActiveSheet.Cells(row, 4).Value
End If
'X pos
ActiveSheet.Cells(row + 1, 42).Value = ActiveSheet.Cells(row, 3).Value
'Y pos
ActiveSheet.Cells(row + 1, 43).Value = ActiveSheet.Cells(row, 2).Value
Next row
'---------------------------------------------------------------------------------------
'Re-organize sheet
For row = 1 To ActiveSheet.UsedRange.Rows.Count + 1
If IsEmpty(ActiveSheet.Cells(row, 1).Value) = True Then
If IsEmpty(ActiveSheet.Cells(row, 44).Value) = True Then
Exit For
End If
ElseIf CountIt = 1 Then
ActiveSheet.Cells(row, 1).Value = "ID"
ActiveSheet.Cells(row, 2).Value = "DESC."
ActiveSheet.Cells(row, 3).Value = "RIM ELEV."
ActiveSheet.Cells(row, 4).Value = "YR_INST"
ActiveSheet.Cells(row, 5).Value = "YR_RETIRE"
ActiveSheet.Cells(row, 6).Value = "ZONE"
ActiveSheet.Cells(row, 7).Value = "PHASE"
ActiveSheet.Cells(row, 8).Value = "INV. ELEV."
ActiveSheet.Cells(row, 9).Value = "DEPTH_RIM"
ActiveSheet.Cells(row, 10).Value = "INIT_DPTH"
ActiveSheet.Cells(row, 11).Value = "SURG_DPTH"
ActiveSheet.Cells(row, 12).Value = "POND_AREA"
ActiveSheet.Cells(row, 13).Value = "FLOOD_TYP"
ActiveSheet.Cells(row, 14).Value = "SD_COEFF"
ActiveSheet.Cells(row, 15).Value = "SELECTED"
ActiveSheet.Cells(row, 16).Value = "SYMBOL"
ActiveSheet.Cells(row, 17).Value = "SYMSIZE"
ActiveSheet.Cells(row, 18).Value = "X"
ActiveSheet.Cells(row, 19).Value = "Y"
ActiveSheet.Cells(row, 20).Value = "Z"
ActiveSheet.Cells(row, 21).Value = "SD_MESH"
CountIt = CountIt + 1
Else
ActiveSheet.Cells(row, 1).Value = ActiveSheet.Cells(row, 44).Value
ActiveSheet.Cells(row, 2).Value = ActiveSheet.Cells(row, 40).Value
ActiveSheet.Cells(row, 3).Value = ActiveSheet.Cells(row, 41).Value
ActiveSheet.Cells(row, 4).Value = ""
ActiveSheet.Cells(row, 5).Value = ""
ActiveSheet.Cells(row, 6).Value = ""
ActiveSheet.Cells(row, 7).Value = ""
ActiveSheet.Cells(row, 8).Value = ActiveSheet.Cells(row, 39).Value
ActiveSheet.Cells(row, 9).Value = ""
ActiveSheet.Cells(row, 10).Value = ""
ActiveSheet.Cells(row, 11).Value = ""
ActiveSheet.Cells(row, 12).Value = ""
ActiveSheet.Cells(row, 13).Value = ""
ActiveSheet.Cells(row, 14).Value = ""
ActiveSheet.Cells(row, 15).Value = ""
ActiveSheet.Cells(row, 16).Value = ""
ActiveSheet.Cells(row, 17).Value = ""
ActiveSheet.Cells(row, 18).Value = ActiveSheet.Cells(row, 42).Value
ActiveSheet.Cells(row, 19).Value = ActiveSheet.Cells(row, 43).Value
ActiveSheet.Cells(row, 20).Value = ActiveSheet.Cells(row, 41).Value
ActiveSheet.Cells(row, 21).Value = ""
For CountThem = 22 To 44
ActiveSheet.Cells(row, CountThem).Value = ""
Next CountThem
End If
Next row
'---------------------------------------------------------------------------------------
'Save converted file as .CSV
MsgBox "Choose the desired save location for the .CSV file."
Dim InitialName As String
Dim PathName As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
InitialName = "sfm_output"
PathName = Application.GetSaveAsFilename(InitialFileName:=InitialName, fileFilter:="CSV (Comma delimited) (*.csv), *.csv")
ws.Copy
ActiveWorkbook.SaveAs Filename:=PathName, _
FileFormat:=xlCSV, CreateBackup:=False
MsgBox "Process completed successfully." & vbNewLine & "File saved to:" & vbNewLine & PathName
'---------------------------------------------------------------------------------------
'Close all Workbooks
Application.DisplayAlerts = False
Application.Quit
End Sub
Разделы, о которых идет речь, являются либо разделом «Подготовка реорганизации листа», либо «Разделом реорганизации листа» (илиобе). Извините, что код в настоящее время небрежный, я просто пытаюсь заставить его работать в первую очередь, прежде чем пройтись и очистить его.
Любая помощь очень ценится!
Редактировать: Не уверен, что случилось с отступом в фрагменте кода ..
Редактировать2: Вот GitHub с файлом .xlsm и примером файла ввода .txt.