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

Question

I am using the code below to generate the single file for selected range and considering the first cell in the selected range as file name. Please find the image below for more details [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

The code below is using a Loop that scans rows in a range that consists of Columns K:N (according to your attached screen-shots).

Assumptions made : your FirstLine is in Column K , and it's the marker of the start position of copying the first cell in the first row. Your LastLine is in Column N , and it's the marker of the last cell to copy, this is why I am closing the file once it is found.

Edit 1 : added a Msgbox to allow the user selection of exporting the entire range or not. In case the user selected NO , then a second InputBox appears that allows the user to enter manually the last row number to export.

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

Edit 2 : Added new code below (to keep the first option valid). The user needs to confirm that every selection he makes start and ends with FirstLine and LastLine , there is no error handling.

Option Explicit Section

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) - new routine to allow handling of multiple Ranges selection

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