使用 vba 脚本单击为 Excel 上的选定数据创建多个文本文件

Question

我正在使用下面的代码为选定范围生成单个文件，并将选定范围中的第一个单元格视为文件名。详情请看下图[This image shows the selected range,Consider K column(Firstline) and N Column( Lastline) to be in one file and other set of 1st and last line in other file ]this image shows the print file for a single file this is the way m currently using for generating files.I need to create more 30k files so please help me to create more files in single click considering the first and last line as header and footer for the file

Private Sub CommandButton1_Click()

Dim myFile As String, rng As Range, cellValue As Variant, i As Integer, j As Integer, path As String, filename, filename2 As String
path = "D:\Watchlist-Files\"

filename = Selection.Cells(1, 1).Value
filename2 = Left(Mid(filename, 32, 99), Len(Mid(filename, 32, 99)) - 2)

myFile = path & filename2

Set rng = Selection

Open myFile For Output As #1

For i = 1 To rng.Rows.Count
    For j = 1 To rng.Columns.Count

cellValue = rng.Cells(i, j).Value


If j = rng.Columns.Count Then
    Print #1, cellValue
Else
    Print #1, cellValue,

End If


   Next j
Next i


Close #1

End Sub

Answer 1

下面的代码使用循环扫描由 K:N 列组成的范围内的行（根据您附加的屏幕截图）。

假设：您的FirstLine在K列中，它是复制第一行第一个单元格的起始位置的标记。 您的LastLine 在N 列 中，它是要复制的最后一个单元格的标记，这就是我在找到文件后关闭文件的原因。

编辑 1：添加了Msgbox 以允许用户选择是否导出整个范围。如果用户选择NO，则会出现第二个InputBox，允许用户手动输入要导出的最后一个行号。

Option Explicit

Public Sub CommandButton1_Click()

Dim myFile                          As String
Dim rng                             As Range
Dim cellValue                       As Variant
Dim i                               As Long
Dim j                               As Long
Dim LastRow                         As Long
Dim path                            As String
Dim filename                        As String
Dim response                        As Boolean

path = "D:\Watchlist-Files\"

response = MsgBox("Do you want to Export the entire Range ? ", vbYesNo)
' Export the entire Range
If response = vbYes Then
    LastRow = Cells(Rows.Count, "N").End(xlUp).Row
Else  ' enter in the inputbox the last row number you want to export
    LastRow = InputBox("Enter Last Row Number you wsnt to Export")
End If
Set rng = Range("K2:N" & LastRow)

For i = 2 To LastRow

    ' Column K holds the file name
    If Cells(i, 11) <> "" Then
        filename = Left(Mid(Cells(i, 11).Value, 32, 99), Len(Mid(Cells(i, 11).Value, 32, 99)) - 2)

        myFile = path & filename
        Open myFile For Output As #1
    End If

    For j = 1 To rng.Columns.Count
        cellValue = Cells(i, 10 + j).Value

        If j = rng.Columns.Count Then
            Print #1, cellValue
            ' found LastLine >> close the file
            If Not cellValue = "" Then
                Close #1
            End If
        Else
            Print #1, cellValue,
        End If
    Next j
Next i

End Sub

编辑 2：在下方添加了新代码（以保持第一个选项有效）。用户需要确认他所做的每一个选择都以FirstLine和LastLine结尾，没有错误处理。

选项显式部分

Option Explicit

Dim filename                        As String
Dim path                            As String
Dim myFile                          As String
Dim rng                             As Range
Dim j                               As Long

Public Sub CommandButton1_Click

Public Sub CommandButton1_Click()

Dim lastRow                         As Long
Dim Sel_Range                       As Long
Dim response                        As Boolean
Dim rowStart()                      As Long
Dim rowFinish()                     As Long

path = "D:\Watchlist-Files\"

response = MsgBox("Do you want to Export only the Selected Range ? ", vbYesNo)
If response = True Then
    Set rng = Selection

    ReDim rowStart(1 To Selection.Areas.Count)
    ReDim rowFinish(1 To Selection.Areas.Count)

    For Sel_Range = 1 To Selection.Areas.Count
        rowStart(Sel_Range) = Selection.Areas(Sel_Range).Row
        rowFinish(Sel_Range) = Selection.Areas(Sel_Range).Row + Selection.Areas(Sel_Range).Rows.Count - 1

        Call CreateTextFiles(rowStart(Sel_Range), rowFinish(Sel_Range))
    Next Sel_Range

Else ' export the entire Range in Columns K:N
    lastRow = Cells(Rows.Count, "N").End(xlUp).Row
    Set rng = Range("K2:N" & lastRow)
    Call CreateTextFiles(2, lastRow)
End If

Sub CreateTextFiles(Sel_StartRow As Long, Sel_FinishRow As Long) - 允许处理多个范围选择的新例程

Sub CreateTextFiles(Sel_StartRow As Long, Sel_FinishRow As Long)

Dim i                               As Long
Dim cellValue                       As Variant

For i = Sel_StartRow To Sel_FinishRow

    ' Column K holds the file name
    If Cells(i, 11) <> "" Then
        filename = Left(Mid(Cells(i, 11).Value, 32, 99), Len(Mid(Cells(i, 11).Value, 32, 99)) - 2)

        myFile = path & filename
        Open myFile For Output As #1
    End If

    For j = 1 To rng.Columns.Count
        cellValue = Cells(i, 10 + j).Value

        If j = rng.Columns.Count Then
            Print #1, cellValue
            ' found LastLine >> close the file
            If Not cellValue = "" Then
                Close #1
            End If
        Else
            Print #1, cellValue,
        End If
    Next j
Next i

End Sub