將 Excel 行導出到文本文件

Question

我見過一些解決方案，但它們並沒有專門做我想做的事情。

我需要能夠做什么：

• 每行創建一個新的文本文件
• 每個單元格都是此文本文件中的新行
• 文件名是第 2 列中的值
• 文件擴展名“.nfo”
• 要保存到的文件夾是第 1 列中的值（絕對路徑）
• 從第 3 行循環到第一個 null 行

我會發布代碼，但我不知道從哪里開始。 有沒有人有任何想法？

Answer 1

例如，我使用了我在評論中發布的鏈接的答案。
我在里面放了一個簡單的循環來循環范圍，在文本文件中為每個值創建一行。

然后我從一個循環中調用另一個子（不是你必須做的事情），該循環遍歷所有行，並且對於每一行，傳遞所述行中所有已使用列的范圍。 此特定代碼要求您添加對Microsoft Scripting Runtime的引用。

Option Explicit

Sub SaveNfo()
Dim ws As Worksheet, rng As Range, LastColumn As Range, rngRow As Variant
Set ws = Worksheets(1)
Set rng = ws.Range("A3:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row) 'start on row 3, include all rows with a filepath

For Each rngRow In rng
    If Not rngRow = "" Then
        SaveTextToFile rngRow & rngRow.Offset(, 1), _
        ws.Range(rngRow.Offset(, 2), Cells(rngRow.Row, ws.Cells(rngRow.Row, ws.Columns.Count).End(xlToLeft).Column))
    End If
Next
End Sub

Private Sub SaveTextToFile(filePath As String, rng As Range)
    Dim cell As Variant
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    Dim fileStream As TextStream
    ' Here the actual file is created and opened for write access
    Set fileStream = fso.CreateTextFile(filePath)
    ' Write something to the file
    For Each cell In rng
            fileStream.WriteLine cell
    Next
    ' Close it, so it is not locked anymore
    fileStream.Close
End Sub

如果文件名列不包含.nfo ，您可以手動將其添加到代碼中：

SaveTextToFile rngRow & rngRow.Offset(, 1), _變為
SaveTextToFile rngRow & rngRow.Offset(, 1) & ".nfo", _

rngRow指向路徑的“A”列。
rngRow.Offset(, 1)是名稱的“B”列。
rngRow.Offset(, 2)然后是 ofc "C"，我們開始尋找要放入文件的數據。

或者，如果您想要真正簡短的版本：

Sub SaveNfo()
Dim rngRow As Variant, cell As Variant, fso As Object, fileStream As Object
For Each rngRow In Range("A3:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    If Not rngRow = "" Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fileStream = fso.CreateTextFile(rngRow & rngRow.Offset(, 1))
        For Each cell In Range(rngRow.Offset(, 2), Cells(rngRow.Row, Cells(rngRow.Row, Columns.Count).End(xlToLeft).Column))
            fileStream.WriteLine cell
        Next
        fileStream.Close
    End If
Next
End Sub

Answer 2

將行導出到文本文件

• 將完整的代碼復制到標准模塊中。
• 在運行exportRowsToTextFiles之前，調整其常量部分和工作表中的值（例如Set ws = ThisWorkbook.Worksheets("Sheet1") ）。
• 取消注釋各種Debug.Print行，以便通過監視Immediate window中的 output 來更好地了解它的工作原理。

Option Explicit

Sub exportRowsToTextFiles()
    
    Const First As String = "A3" ' First Data Cell Address
    Const fCol As Long = 1 ' First Column
    Const fpCol As Long = 1 ' File Path Column
    Const fbnCol As Long = 2 ' File Base Name Column
    Const fExt As String = ".nfo" ' File Extension
    Const ccSep As String = vbLf ' Cell Contents Separator
    Dim pSep As String: pSep = Application.PathSeparator
    
    If ActiveSheet Is Nothing Then Exit Sub ' if run from an Add-in
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub ' if e.g. chart
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    Dim brrg As Range: Set brrg = refBottomRightRange(ws.Range(First))
    'Debug.Print "Bottom Right Range: " & brrg.Address
    
    Dim nerg As Range: Set nerg = refNonEmptyRange(brrg)
    If nerg Is Nothing Then Exit Sub
    'Debug.Print "Non-Empty Range:    " & nerg.Address
    
    Dim Data As Variant: Data = getRange(nerg)
    'Debug.Print "Data Array:", "Rows=" & UBound(Data, 1), _
        "Columns=" & UBound(Data, 2)

    Dim rDat As Variant: ReDim rDat(0 To UBound(Data, 2) - fCol)
    
    Dim FilePath As String
    Dim r As Long, c As Long, n As Long
    
    For r = 1 To UBound(Data, 1)
        If Len(Data(r, fpCol)) > 0 Then
            If Len(Data(r, fbnCol)) > 0 Then
                FilePath = Data(r, fpCol) & pSep & Data(r, fbnCol) & fExt
                'Debug.Print FilePath
                n = -1
                For c = fCol To UBound(Data, 2)
                    n = n + 1
                    rDat(n) = Data(r, c)
                    'Debug.Print r, c, n, rDat(n)
                Next c
            End If
        End If
        writeStringToFile FilePath, Join(rDat, ccSep)
    Next r
    
End Sub

Function refBottomRightRange( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    With FirstCell.Worksheet
        Set refBottomRightRange _
            = .Range(FirstCell(1), .Cells(.Rows.Count, .Columns.Count))
    End With
End Function
Sub refBottomRightRangeTEST()
    Dim FirstCell As Range: Set FirstCell = Range("C5")
    Dim rg As Range: Set rg = refBottomRightRange(FirstCell)
    If Not rg Is Nothing Then Debug.Print rg.Address
End Sub

Function refBottomRightResize( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    With FirstCell
        Set refBottomRightResize = .Resize(.Worksheet.Rows.Count - .Row + 1, _
            .Worksheet.Columns.Count - .Column + 1)
    End With
End Function
Sub refBottomRightResizeTEST()
    Dim FirstCell As Range: Set FirstCell = Range("C5")
    Dim rg As Range: Set rg = refBottomRightResize(FirstCell)
    If Not rg Is Nothing Then Debug.Print rg.Address
End Sub

Function refNonEmptyRange( _
    ByVal rg As Range) _
As Range
    If rg Is Nothing Then Exit Function
    Dim lCell As Range
    Set lCell = rg.Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If lCell Is Nothing Then Exit Function
    With rg.Resize(lCell.Row - rg.Row + 1)
        Set refNonEmptyRange = .Resize(, _
            .Find("*", , , , xlByColumns, xlPrevious).Column - .Column + 1)
    End With
End Function
Sub refNonEmptyRangeTEST()
    Dim irg As Range: Set irg = Range("C5:F10")
    Dim rg As Range: Set rg = refNonEmptyRange(irg)
    If Not rg Is Nothing Then Debug.Print rg.Address
End Sub

Function getRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    If rg.Rows.Count = 1 And rg.Columns.Count = 1 Then
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        getRange = Data
    Else
        getRange = rg.Value
    End If
End Function

Sub writeStringToFile( _
        ByVal FilePath As String, _
        ByVal FileText As String)
    On Error GoTo clearError ' if file path is invalid (folder doesn't exist)
    Dim FileNum As Long: FileNum = FreeFile
    Open FilePath For Output As #FileNum
    Print #FileNum, FileText
    Close #FileNum
ProcExit:
    Exit Sub
clearError:
    Resume ProcExit
End Sub