[英]import text file data into excel workbook 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將數據作為字符串導入。 然后按深度拆分數據。 通過vbNewLine進一步拆分該數組。 最后強制TexttoColumns。 概率不是更有效的方法，但是過去對我有用。
基本示例：
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
Excel VBA-使用“〜”定界值將多個文本文件導入同一工作簿
[英]Excel VBA - import multiple text files into same workbook with “~” delimited values
聲明:本站的技術帖子網頁，遵循CC BY-SA 4.0協議，如果您需要轉載，請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.