Fatal编程技术网
  • excel/
  • Excel 将.xlsx文件的每一行保存为.txt

Excel 将.xlsx文件的每一行保存为.txt

excel vba

Excel 将.xlsx文件的每一行保存为.txt,excel,vba,Excel,Vba,我有一个Excel电子表格，有300多行，只有一列。我需要将每一行（更准确地说是每一个单元格，因为我只使用一列）保存到不同的.txt文件中，每个文件都有其单元格的名称。例如，如果在A1中我有“pizza”，结果应该是一个名为“pizza”的.txt文件，其中只包含单词“pizza”。在那之后，A2加上“苹果”，A3，A4。。。等等，直到最后。有可能吗？我在这里问是因为我对这个很陌生，没有其他人可以问。谢谢大家 编辑：我试过了，但没用。我不知道我做错了什么，如果我在路径部分出错了什么的。我没有重复

我有一个Excel电子表格，有300多行，只有一列。我需要将每一行（更准确地说是每一个单元格，因为我只使用一列）保存到不同的.txt文件中，每个文件都有其单元格的名称。例如，如果在A1中我有“pizza”，结果应该是一个名为“pizza”的.txt文件，其中只包含单词“pizza”。在那之后，A2加上“苹果”，A3，A4。。。等等，直到最后。有可能吗？我在这里问是因为我对这个很陌生，没有其他人可以问。谢谢大家

编辑：我试过了，但没用。我不知道我做错了什么，如果我在路径部分出错了什么的。我没有重复的，我查过了。 我真的没有比这更详细的了

Option Explicit

Sub CreateTextFileForEachRow()
Dim Fso As Object: Set Fso = CreateObject("scripting.filesystemobject")
Dim Txt As Object
Dim row As Long, Lr As Long
Dim Val As String

Dim DestinationFolder As String
DestinationFolder = "C:\users" & Environ("username") & "\Desktop\"

With ActiveSheet
    Lr = .Cells(.Rows.Count, "A").End(xlUp).row
    For row = 2 To Lr
        Val = .Cells(row, "A")
        Set Txt = Fso.CreateTextFile(DestinationFolder & Val & ".txt", True)
        Txt.WriteLine (Val)
        Txt.Close
    Next row

End With

End Sub
从单元格值创建文本文件 快速修复

Sub CreateTextFileForEachRow()
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim Txt As Object
    Dim cRow As Long, Lr As Long
    Dim cVal As String
    
    Dim DestinationFolder As String
    DestinationFolder = "C:\users\" & Environ("username") & "\Desktop\"
    
    With ActiveSheet
        Lr = .Cells(.Rows.Count, "A").End(xlUp).Row
        For cRow = 2 To Lr
            cVal = .Cells(cRow, "A").Value
            Set Txt = fso.CreateTextFile(DestinationFolder & cVal & ".txt", True)
            Txt.WriteLine (cVal)
            Txt.Close
        Next cRow
    End With

End Sub
  • 在使用以下两个版本中的任何一个之前，请调整其“常量”部分中的值。如有必要，使用
    Dim
    代替
    Const
    DestinationFolder
    在这些解决方案中是
    FolderPath
紧凑型

Sub createTextFiles()
    
    Const FolderPath As String = "F:\Test\2021\65565907\Files"
    Const FileExtension As String = ".txt"
    Const wbPath As String = "F:\Test\2021\65565907\Test.xlsx"
    Const wsName As String = "Sheet1"
    Const FirstCellAddress As String = "A2"
    
    Dim rng As Range
    Dim Data As Variant
    
    ' Open Source Workbook.
    'With ActiveSheet
    With Workbooks.Open(wbPath).Worksheets(wsName).Range(FirstCellAddress)
        ' Attempt to define the Last-Non Empty Cell.
        Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1).Find( _
            What:="*", _
            LookIn:=xlFormulas, _
            SearchDirection:=xlPrevious)
        ' Validate Last Non-Empty Cell.
        If rng Is Nothing Then
            Exit Sub
        End If
        ' Define Source Range.
        Set rng = .Resize(rng.Row - .Row + 1)
        ' Write values from Source Column Range to Data Array (2D).
        If rng.Cells.CountLarge > 1 Then
            Data = rng.Value
        Else
            ReDim Data(1 To 1, 1 To 1)
            Data(1, 1) = rng.Value
        End If
        .Worksheet.Parent.Close SaveChanges:=False ' Reconsider if ActiveSheet.
    End With
    
    Dim cValue As Variant
    Dim i As Long
    
    With CreateObject("Scripting.Dictionary")
       ' Write unique values from Data Array (2D) to Unique Dictionary.
        .CompareMode = vbTextCompare
        For i = 1 To UBound(Data, 1)
            cValue = Data(i, 1)
            If Not IsError(cValue) Then
                If Not IsEmpty(cValue) Then
                    .Item(cValue) = Empty
                End If
            End If
        Next i
        ' Validate Unique Dictionary.
        If .Count = 0 Then
            Exit Sub
        End If
        ' Write values from keys of Unique Dictionary to Data Array (1D).
        Data = .Keys
    End With
    
    ' Create and write to the files.
    With CreateObject("Scripting.FileSystemObject")
        For i = 0 To UBound(Data)
            With .CreateTextFile( _
                    .BuildPath(FolderPath, Data(i) & FileExtension), True)
                .WriteLine Data(i)
                .Close
            End With
        Next i
    End With
    
    ' Inform user.
    MsgBox "Files created.", vbInformation, "Success"
    
    ' Navigate to folder path in File Explorer.
    ThisWorkbook.FollowHyperlink FolderPath

End Sub
重构

Sub createTextFilesRefactored()
    
    Const FolderPath As String = "F:\Test\2021\65565907\Files"
    Const FileExtension As String = "txt"
    Const wbPath As String = "F:\Test\2021\65565907\Test.xlsx"
    Const wsName As String = "Sheet1"
    Const Cols As String = "A"
    Const FirstRow As Long = 2
    
    Dim rng As Range
    Dim Data As Variant
    Dim Unique As Variant
    
    ' Data
    Application.ScreenUpdating = False
    With Workbooks.Open(wbPath).Worksheets(wsName)
        Set rng = defineNonEmptyColumnRange(.Columns(Cols), FirstRow)
        If rng Is Nothing Then
            GoTo ProcExit
        End If
        Data = getRange(rng)
        .Parent.Close SaveChanges:=False
    End With
    Application.ScreenUpdating = True
    
    ' Unique
    Unique = UniqueToArray(Data)
    If IsEmpty(Unique) Then
        GoTo ProcExit
    End If
    
    ' Result
    createAndWriteToTextFilesFromArray Unique, FolderPath, FileExtension
    MsgBox "Files created.", vbInformation, "Success"
    ThisWorkbook.FollowHyperlink FolderPath

ProcExit:
    Exit Sub

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Defines the range of a range containing data (values): from
'               the first row (not necessarily containing data) to the last row
'               containing data.
' Remarks:      Usually the first row is known i.e. determined 'manually'.
'               If it isn't, omitting 'FirstRow' or setting it to 0
'               will trigger its calculation.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function defineNonEmptyColumnRange( _
    rng As Range, _
    Optional ByVal FirstRow As Long = 0) _
As Range
    
    Const ProcName As String = "defineNonEmptyColumnRange"
    On Error GoTo clearError
    
    If rng Is Nothing Then
        GoTo ProcExit
    End If
    
    Dim pRng As Range
    Dim cel As Range
    Select Case FirstRow
        Case Is < 0, Is > rng.Rows.Count
        Case 0
            Set cel = rng.Find( _
                What:="*", _
                After:=rng(rng.CountLarge), _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows)
            If cel Is Nothing Then
                GoTo ProcExit
            End If
            Set pRng = rng.Resize(rng.Rows.Count + rng.Row - cel.Row) _
                .Offset(cel.Row - rng.Row)
            Set cel = Nothing
        Case 1
            Set pRng = rng
        Case Else
            Set pRng = rng.Resize(rng.Rows.Count - FirstRow + 1) _
                .Offset(FirstRow - 1)
    End Select
    Set cel = pRng.Find( _
        What:="*", _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious)
    If cel Is Nothing Then
        GoTo ProcExit
    End If
    Set defineNonEmptyColumnRange = pRng.Resize(cel.Row - pRng.Row + 1)

ProcExit:
    Exit Function

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the values from a range to a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getRange( _
    rng As Range) _
As Variant
     
    Const ProcName As String = "getRange"
    On Error GoTo clearError
    
    If rng Is Nothing Then
        GoTo ProcExit
    End If
    
    Dim Data As Variant
    
    If rng.Cells.CountLarge > 1 Then
        Data = rng.Value
    Else
        ReDim Data(1 To 1, 1 To 1)
        Data(1, 1) = rng.Value
    End If
 
    getRange = Data

ProcExit:
    Exit Function

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the unique values from a 2D array
'               to a 1D zero-based array, excluding error and empty values.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function UniqueToArray( _
    TwoD As Variant) _
As Variant
    
    Const ProcName As String = "UniqueToArray"
    On Error GoTo clearError
    
    If IsEmpty(TwoD) Then
        GoTo ProcExit
    End If
    
    Dim cLower As Long: cLower = LBound(TwoD, 2)
    Dim cUpper As Long: cUpper = UBound(TwoD, 2)
    
    Dim cValue As Variant
    Dim i As Long
    Dim j As Long
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For i = LBound(TwoD, 1) To UBound(TwoD, 1)
            For j = cLower To cUpper
                cValue = TwoD(i, j)
                If Not IsError(cValue) Then
                    If Not IsEmpty(cValue) Then
                        .Item(cValue) = Empty
                    End If
                End If
            Next j
        Next i
        If .Count > 0 Then
            UniqueToArray = .Keys
        End If
    End With

ProcExit:
    Exit Function

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates text files named by values from an array and at
'               the same time writes the same value to the text file.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub createAndWriteToTextFilesFromArray( _
        OneD As Variant, _
        ByVal FolderPath As String, _
        Optional ByVal FileExtension As String = "txt")
    
    Const ProcName As String = "createAndWriteToTextFilesFromArray"
    On Error GoTo clearError
    
    If IsEmpty(OneD) Then
        GoTo ProcExit
    End If
    
    Dim n As Long
    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(FolderPath) Then
            .CreateFolder (FolderPath)
        End If
        For n = LBound(OneD) To UBound(OneD)
            On Error Resume Next ' File name validation maybe more appropriate.
            With .CreateTextFile( _
                    .BuildPath(FolderPath, OneD(n) & "." & FileExtension), True)
                If Err.Number = 0 Then
                    .WriteLine OneD(n)
                    .Close
                End If
            End With
            On Error GoTo clearError
        Next n
    End With

ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit

End Sub

Sub-createTextFileRefactured（）
Const FolderPath As String=“F:\Test\2021\65565907\Files”
常量文件扩展名为String=“txt”
Const wbPath As String=“F:\Test\2021\65565907\Test.xlsx”
Const wsName As String=“Sheet1”
Const Cols As String=“A”
常量第一行长度=2
变暗rng As范围
作为变量的Dim数据
Dim作为变体是唯一的
"数据,
Application.ScreenUpdating=False
使用工作簿.打开（wbPath）.工作表（wsName）
设置rng=defineNonEmptyColumnRange（.Columns（Cols），第一行）
如果rng不算什么，那么
转到出口
如果结束
数据=获取范围（rng）
.Parent.Close SaveChanges:=False
以
Application.ScreenUpdating=True
“独一无二的
唯一=唯一阵列（数据）
如果是空的（唯一的），那么
转到出口
如果结束
"结果,
createAndWriteToTextFilesFromArray唯一、FolderPath、文件扩展名
MsgBox“已创建文件”，vbInformation，“成功”
ThisWorkbook.FollowHyperlink文件夹路径
程序出口：
出口接头
端接头
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'用途：定义包含数据（值）的范围：从
'从第一行（不一定包含数据）到最后一行
“包含数据。
备注：通常第一行是已知的，即“手动”确定。
'如果不是，则省略'FirstRow'或将其设置为0
"将触发其计算。
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
函数定义无限制列范围（_
rng作为射程_
可选的ByVal（第一行，长度=0）_
As范围
Const ProcName As String=“defineNonEmptyColumnRange”
关于错误转到clearError
如果rng不算什么，那么
转到出口
如果结束
变暗pRng As范围
暗淡的cel As范围
选择案例第一行
大小写为<0，大小写为>rng.Rows.Count
案例0
设置cel=rng.Find（_
什么：=“*”_
之后：=rng（rng.CountLarge）_
LookIn:=xl公式_
搜索顺序：=xlByRows）
如果凯尔什么都不是
转到出口
如果结束
设置pRng=rng.Resize（rng.Rows.Count+rng.Row-cel.Row）_
.偏移量（cel.Row-rng.Row）
设置cel=Nothing
案例1
设置pRng=rng
其他情况
设置pRng=rng.Resize（rng.Rows.Count-FirstRow+1）_
.偏移量（第一行-1）
结束选择
设置cel=pRng.Find（_
什么：=“*”_
LookIn:=xl公式_
搜索顺序：=xlByRows_
SearchDirection:=xlPrevious）
如果凯尔什么都不是
转到出口
如果结束
设置defineNonEmptyColumnRange=pRng.Resize（cel.Row-pRng.Row+1）
程序出口：
退出功能
clearError：
Debug.Print“”&ProcName&“：意外错误！”&vbLf_
&“&”运行时错误“&”错误编号&“：”&vbLf_
&“”错误描述（&R）
恢复程序退出
端函数
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'用途：将范围中的值写入基于一个数组的二维数组。
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
函数getRange（_
rng As范围）_
作为变体
Const ProcName As String=“getRange”
关于错误转到clearError
如果rng不算什么，那么
转到出口
如果结束
作为变量的Dim数据
如果rng.Cells.CountLarge>1，则
数据=平均值
其他的
重拨数据（1对1，1对1）
数据（1，1）=参考值
如果结束
getRange=数据
程序出口：
退出功能
clearError：
Debug.Print“”&ProcName&“：意外错误！”&vbLf_
&“&”运行时错误“&”错误编号&“：”&vbLf_
&“”错误描述（&R）
恢复程序退出
端函数
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'用途：写入二维数组中的唯一值
'到1D零基数组，不包括错误值和空值。
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
函数唯一数组（_
TwoD（作为变体）_
作为变体
Const ProcName As String=“UniqueToArray”
关于错误转到clearError
如果我是空的，那么
转到出口
如果结束
长时变暗cLower:cLower=LBound（两个D，2）
与长度相同的尺寸杯：杯=UBound（两个D，2个）
作为变量的Dim C值
我想我会坚持多久
Dim j尽可能长
使用CreateObject（“Scripting.Dictionary”）
.CompareMode=vbTextCompare
对于i=LBound(