Question

我有一个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。

Answer 1

也许这会对你有所帮助：

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

Answer 2

由于深度仅在数据集中出现一次，因此Split（）函数可能会起作用。不要使用表查询，而是尝试使用FileSystemsObject将数据作为字符串导入。然后在Depth上拆分数据。进一步通过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

Answer 3

这是我最终使用的代码，我最终做了两个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

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

3 个答案: