ワンクリックで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を選択した場合は、最後にエクスポートする行番号を手動で入力できるようにするもう1つの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節

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 

サブCreateTextFiles（ロング限りSel_StartRow、Sel_FinishRow） - 新しいルーチンは、複数の範囲の取り扱いを可能にします選択

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