将文本文件数据导入到Excel工作簿VBA中
我有一个Excel工作簿，其中用户导入文本文件信息进行计算和绘图生成。 我的代码工作很好，但我遇到了一些问题。 对于大多数文本文件，我需要开始复制从第2行的信息，但有几个文本文件，我需要开始从不同的行复制信息（见下面的两个图像）。 所以基本上我需要开始复制一行下面一行说“深度”的信息。 
^这个图像在文本文件的第一行有深度。 
^这个图像的深度在文本文件中更深。
这里是我目前用于导入文本文件的代码：
Sub Import_Textfiles() Dim fName As String, LastCol As Integer With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Worksheets("Data Importation Sheet").Activate LastCol = Cells(2, Columns.count).End(xlToLeft).Column If LastCol > 1 Then LastCol = LastCol + 1 End If fName = Application.GetOpenFilename("Text Files (*.txt), *.txt") If fName = "False" Then Exit Sub With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fName, _ Destination:=Cells(2, LastCol)) .Name = "2001-02-27 14-48-00" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = False .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 437 .TextFileStartRow = 2 .TextFileParseType = xlFixedWidth .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1) .TextFileFixedColumnWidths = Array(14, 14, 8, 16, 12, 14) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With Call Macro 'counts the number of times this macro runs aka identifier Dim strShortName As String Dim string1 As String Dim reference As Range Dim emptycell As Integer Dim LastRow As Integer Dim LastRow2 As Integer Dim LastRow3 As Integer i = Worksheets("Hidden").Range("B2").Value string1 = Worksheets("Hidden").Cells(i + 1, 1) Worksheets("Data Importation Sheet").Activate Cells(1, LastCol) = "Depth" Cells(1, LastCol + 1) = "A0_ " & string1 Cells(1, LastCol + 2) = "A180_ " & string1 Cells(1, LastCol + 3) = "A_Sum_ " & string1 Cells(1, LastCol + 4) = "B0_ " & string1 Cells(1, LastCol + 5) = "B180_ " & string1 Cells(1, LastCol + 6) = "B_Sum_ " & string1 'New Adding Reading Date to Excel Sheet: Dim fileDate1 As String Dim fileDate2 As String Dim A As String fileDate1 = Mid(fName, InStrRev(fName, "\") + 1) fileDate2 = Left(fileDate1, 19) LastRow = Cells(Rows.count, LastCol).End(xlUp).Row + 1 LastRow2 = Cells(Rows.count, LastCol).End(xlUp).Row A = Cells(LastRow2, LastCol).Value Cells(LastRow + 1, LastCol) = "Reading Date:" Cells(LastRow + 2, LastCol) = fileDate2 Cells(LastRow + 3, LastCol) = "Updating Location:" Cells(LastRow + 4, LastCol) = fName Cells(LastRow + 5, LastCol) = "Depth:" Cells(LastRow + 6, LastCol) = A Cells(LastRow + 7, LastCol) = "Identifier:" Cells(LastRow + 8, LastCol) = string1 Sheets("Hidden").Activate LastRow3 = Cells(Rows.count, 3).End(xlUp).Row Cells(LastRow3 + 1, 3) = fileDate2 Call SortDates 'organizes imported text file dates and identifiers End Sub 任何人都可以帮我得到我的代码工作的任何案件的文本文件数据布局？ TIA。
也许这会帮助你：
Sub Import_Textfiles() Dim fName As String, LastCol As Integer Dim lngDepthRow As Long With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Worksheets("Data Importation Sheet").Activate LastCol = Cells(2, Columns.Count).End(xlToLeft).Column If LastCol > 1 Then LastCol = LastCol + 1 End If fName = Application.GetOpenFilename("Text Files (*.txt), *.txt") If fName = "False" Then Exit Sub With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fName, _ Destination:=Cells(2, LastCol)) .Name = "2001-02-27 14-48-00" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = False .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 437 .TextFileStartRow = 2 .TextFileParseType = xlFixedWidth .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1) .TextFileFixedColumnWidths = Array(14, 14, 8, 16, 12, 14) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With With ActiveSheet lngDepthRow = .Cells.Find(what:="Depth", lookat:=xlWhole).Row If lngDepthRow <> 1 Then .Rows("1:" & lngDepthRow).Delete shift:=xlUp Else .Rows("1").Delete shift:=xlUp End If End With Call Macro 'counts the number of times this macro runs aka identifier Dim strShortName As String Dim string1 As String Dim reference As Range Dim emptycell As Integer Dim LastRow As Integer Dim LastRow2 As Integer Dim LastRow3 As Integer i = Worksheets("Hidden").Range("B2").Value string1 = Worksheets("Hidden").Cells(i + 1, 1) Worksheets("Data Importation Sheet").Activate Cells(1, LastCol) = "Depth" Cells(1, LastCol + 1) = "A0_ " & string1 Cells(1, LastCol + 2) = "A180_ " & string1 Cells(1, LastCol + 3) = "A_Sum_ " & string1 Cells(1, LastCol + 4) = "B0_ " & string1 Cells(1, LastCol + 5) = "B180_ " & string1 Cells(1, LastCol + 6) = "B_Sum_ " & string1 'New Adding Reading Date to Excel Sheet: Dim fileDate1 As String Dim fileDate2 As String Dim A As String fileDate1 = Mid(fName, InStrRev(fName, "\") + 1) fileDate2 = Left(fileDate1, 19) LastRow = Cells(Rows.Count, LastCol).End(xlUp).Row + 1 LastRow2 = Cells(Rows.Count, LastCol).End(xlUp).Row A = Cells(LastRow2, LastCol).Value Cells(LastRow + 1, LastCol) = "Reading Date:" Cells(LastRow + 2, LastCol) = fileDate2 Cells(LastRow + 3, LastCol) = "Updating Location:" Cells(LastRow + 4, LastCol) = fName Cells(LastRow + 5, LastCol) = "Depth:" Cells(LastRow + 6, LastCol) = A Cells(LastRow + 7, LastCol) = "Identifier:" Cells(LastRow + 8, LastCol) = string1 Sheets("Hidden").Activate LastRow3 = Cells(Rows.Count, 3).End(xlUp).Row Cells(LastRow3 + 1, 3) = fileDate2 Call SortDates 'organizes imported text file dates and identifiers End Sub
由于深度仅在数据集中出现一次，Split（）函数可能会工作。 而不是使用表查询，请尝试使用FileSystemsObject将数据作为string导入。 然后在深度分割数据。 进一步拆分vbNewLine的数组。 最后强制TexttoColumns。 Probaby不是更有效的方式，但过去为我工作。
基本示例：
Option Explicit Sub DataSplit() Dim fsoReader As Object Dim fsoDataFile As Object Dim strData As String Dim strSplitAtDepth() As String Dim strSplitAtNewLine() As String Dim strSplitData As Variant Dim intOffsetCounter As Integer 'opens file and reads data to a string Set fsoReader = CreateObject("Scripting.FileSystemObject") Set fsoDataFile = fsoReader.OpenTextFile("FilePathHere", 1) '1 is ForReading strData = fsoDataFile.ReadAll 'First split at B Sum, and wanted data guarenteed to be in second array entry. 'Second split at new line, in prep for the Text to Columns later strSplitAtDepth() = Split(strData, "B Sum", , vbTextCompare) strSplitAtNewLine = Split(strSplitAtDepth(1), vbLF, , vbBinaryCompare) 'Puts each newline split in its own row intOffsetCounter = 0 For Each strSplitData In strSplitAtNewLine() Range("A1").Offset(0, intOffsetCounter).Value2 = strSplitData intOffsetCounter = intOffsetCounter + 1 Next Range("A1", Range("A1").End(xlDown)).TextToColumns ConsecutiveDelimiter:=True End Sub
这里是我最后去的代码，我最终做了两个if语句像这样
Public i As Integer Sub Import_Textfiles() Dim fName As String, LastCol As Integer Dim strSearch As String Dim strSearch2 As String Dim f As Integer Dim lngLine As Long Dim lngLineInt As Integer Dim strLine As String With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Worksheets("Data Importation Sheet").Activate LastCol = Cells(2, Columns.count).End(xlToLeft).Column If LastCol > 1 Then LastCol = LastCol + 1 End If fName = Application.GetOpenFilename("Text Files (*.txt), *.txt") If fName = "False" Then Exit Sub strSearch = "Depth " strSearch2 = "Water Level" f = FreeFile Open fName For Input As #f Do While Not EOF(f) lngLine = lngLine + 1 lngLineInt = CInt(lngLine + 1) Line Input #f, strLine If InStr(1, strLine, strSearch, vbTextCompare) > 0 Then With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fName, _ Destination:=Cells(2, LastCol)) .Name = "2001-02-27 14-48-00" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = False .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 437 .TextFileStartRow = lngLineInt .TextFileParseType = xlFixedWidth .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1) .TextFileFixedColumnWidths = Array(14, 14, 8, 16, 12, 14) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With Exit Do End If If InStr(1, strLine, strSearch2, vbTextCompare) > 0 Then lngLineInt = lngLineInt + 6 With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fName, _ Destination:=Cells(2, LastCol)) .Name = "2001-02-27 14-48-00" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = False .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 437 .TextFileStartRow = lngLineInt .TextFileParseType = xlDelimited .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = True .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1) .TextFileFixedColumnWidths = Array(14, 14, 8, 16, 12, 14) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With Exit Do End If Loop Close #f Call Macro 'counts the number of times this macro runs aka identifier Dim strShortName As String Dim string1 As String Dim reference As Range Dim emptycell As Integer Dim LastRow As Integer Dim LastRow2 As Integer Dim LastRow3 As Integer i = Worksheets("Hidden").Range("B2").Value string1 = Worksheets("Hidden").Cells(i + 1, 1) Worksheets("Data Importation Sheet").Activate Cells(1, LastCol) = "Depth" Cells(1, LastCol + 1) = "A0_ " & string1 Cells(1, LastCol + 2) = "A180_ " & string1 Cells(1, LastCol + 3) = "A_Sum_ " & string1 Cells(1, LastCol + 4) = "B0_ " & string1 Cells(1, LastCol + 5) = "B180_ " & string1 Cells(1, LastCol + 6) = "B_Sum_ " & string1 'New Adding Reading Date to Excel Sheet: Dim fileDate1 As String Dim fileDate2 As String Dim A As String fileDate1 = Mid(fName, InStrRev(fName, "\") + 1) fileDate2 = Left(fileDate1, 19) LastRow = Cells(Rows.count, LastCol).End(xlUp).Row + 1 LastRow2 = Cells(Rows.count, LastCol).End(xlUp).Row A = Cells(LastRow2, LastCol).Value Cells(LastRow + 1, LastCol) = "Reading Date:" Cells(LastRow + 2, LastCol) = fileDate2 Cells(LastRow + 3, LastCol) = "Updating Location:" Cells(LastRow + 4, LastCol) = fName Cells(LastRow + 5, LastCol) = "Depth:" Cells(LastRow + 6, LastCol) = A Cells(LastRow + 7, LastCol) = "Identifier:" Cells(LastRow + 8, LastCol) = string1 Sheets("Hidden").Activate LastRow3 = Sheets("Hidden").Cells(Rows.count, 3).End(xlUp).Row Cells(LastRow3 + 1, 3) = fileDate2 Call SortDates End Sub