将文本文件数据导入到excel工作簿VBA

问题描述：

我有一个excel工作簿，其中用户导入用于计算和绘图的文本文件信息以生成。我的代码工作得很好，但我遇到了一些问题。对于大多数文本文件，我需要从第2行开始复制信息，但是有几个文本文件需要从另一行开始复制信息（请参见下面的两个图像）。所以基本上我需要开始复制信息的一行下面一行说“深度”。将文本文件数据导入到excel工作簿VBA

^此图像在文本文件的第一行有深度。 ^这个图像的深度在文本文件中更深。

这里是我的代码目前已导入的文本文件：

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

答

由于深度只有在数据集中出现一次，斯普利特（）函数可能会工作。不要使用表格查询，请尝试使用FileSystemsObject将数据作为字符串导入。然后在深度上分割数据。进一步通过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

声明，我收到了“用户定义类型没有定义'Dim for fsoReader As Scripting.FileSystemObject – hdk857

已解决上述问题，但现在在代码：Range（“A1”）。Offset（0，intOffsetCounter）.Text = strSplitData我得到错误'Object Required' – hdk857

我忘记了一组范围的前面，并忘记完成切换回迟装订。对不起，关于 – ThatOneGuy

答

这里是我结束了去的代码，我最终做了两，如果像这样

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

将文本文件数据导入到excel工作簿VBA

相关推荐