複数のシートから新しい複数のシートに抽出されるVBAコード

Question

私は初心者のVBAユーザーですが、複数のタブを持つユーザーフォームを持つブックを作成しました。ユーザーが適切なタブを選択してデータを入力すると、該当するワークシートに転送されます。ワークシートにコマンドボタンがあり、これをクリックすると日付範囲を指定するように求められ、次に、適用可能な各ワークシートから転送されたデータを抽出し、各ユーザーの別々の新しいワークシートに配置します（全員のデータが異なるため）。私がコンパイルした以下のVBAコードは正しく処理されていません。代わりに、1つのワークシートからデータを取り出し、それを新しい個々のワークシートに配置します。

Sub Copy_Click() 

Dim startdate As Date, enddate As Date 
Dim rng As Range, destRow As Long 
Dim shtSrc1 As Worksheet 
Dim shtSrc2 As Worksheet 
Dim shtSrc3 As Worksheet 
Dim shtDest1 As Worksheet 
Dim shtDest2 As Worksheet 
Dim shtDest3 As Worksheet 

Dim c As Range 

Set shtSrc1 = Sheets("Recruiter") 
Set shtSrc2 = Sheets("SrRecruiter") 
Set shtSrc3 = Sheets("RecruiterSpc") 

Set shtDest1 = Sheets("Extract_Recrt") 
Set shtDest2 = Sheets("Extract_SrRecrt") 
Set shtDest3 = Sheets("Extract_RecrtSpc") 

destRow = 2 'start copying to this row 

startdate = CDate(InputBox("Input desired start date for report data")) 
enddate = CDate(InputBox("Input desired end date for report data")) 

'don't scan the entire column... 
Set rng = Application.Intersect(shtSrc1.Range("A:A"), shtSrc1.UsedRange) 
Set rng = Application.Intersect(shtSrc2.Range("A:A"), shtSrc2.UsedRange) 
Set rng = Application.Intersect(shtSrc3.Range("A:A"), shtSrc3.UsedRange) 

For Each c In rng.Cells 
    If c.Value >= startdate And c.Value <= enddate Then 

     c.Offset(0, 0).Resize(1, 25).Copy _ 
         shtDest1.Cells(destRow, 1) 

     c.Offset(0, 0).Resize(1, 25).Copy _ 
         shtDest2.Cells(destRow, 1) 

     c.Offset(0, 0).Resize(1, 25).Copy _ 
         shtDest3.Cells(destRow, 1) 


     destRow = destRow + 1 

     End If 
    Next 

    End Sub 

私が間違ってやっていることを誰にも教えてください。

Answer 1

のでわからないが、あなたはこの

Option Explicit 

Sub Copy_Click() 
Dim startdate As Date, enddate As Date 
Dim rng As Range, c As Range 
Dim destRow(1 To 3) As Long 
Dim shtSrc(1 To 3) As Worksheet 
Dim shtDest(1 To 3) As Worksheet 
Dim i As Long  

Set shtSrc(1) = Sheets("Recruiter") 
Set shtSrc(2) = Sheets("SrRecruiter") 
Set shtSrc(3) = Sheets("RecruiterSpc") 

Set shtDest(1) = Sheets("Extract_Recrt") 
Set shtDest(2) = Sheets("Extract_SrRecrt") 
Set shtDest(3) = Sheets("Extract_RecrtSpc") 

destRow(1) = 2: destRow(2) = 2: destRow(3) = 2 

startdate = CDate(InputBox("Input desired start date for report data")) 
enddate = CDate(InputBox("Input desired end date for report data")) 

For i = 1 To 3 
    Set rng = shtSrc(i).Range("A:A").SpecialCells(xlCellTypeConstants, xlNumbers) 'this will select only numbers constants. since dates are numbers they'll get into this range 
    For Each c In rng 
     If c.Value >= startdate And c.Value <= enddate Then 
      c.Offset(0, 0).Resize(1, 25).Copy Destination:=shtDest(i).Cells(destRow(i), 1) 
      destRow(i) = destRow(i) + 1 
     End If 
    Next c 
Next i 


End Sub 

Answer 2

まず、rng変数を設定して上書きしているようです。 私はこのようなコードを3 rngの変数が必要になるように変更しました。

すなわち、

Dim rng(1 To 3) 

Set rng(1) = Application.Intersect(shtSrc1.Range("A:A"), shtSrc1.UsedRange) 
Set rng(2) = Application.Intersect(shtSrc2.Range("A:A"), shtSrc2.UsedRange) 
Set rng(3) = Application.Intersect(shtSrc3.Range("A:A"), shtSrc3.UsedRange) 

次に、先ほど設定した各範囲をループしfor loopを使用します。完全なコードは以下のとおりです。

あなたのニーズについて

Sub Copy_Click() 
    　Dim startdate As Date, enddate As Date 
    Dim rng(1 To 3) As Range, destRow As Long 
    Dim shtSrc1 As Worksheet 
    Dim shtSrc2 As Worksheet 
    Dim shtSrc3 As Worksheet 
    Dim shtDest(1 To 3) As Worksheet 


    Dim c As Range 

    Set shtSrc1 = Sheets("Recruiter") 
    Set shtSrc2 = Sheets("SrRecruiter") 
    Set shtSrc3 = Sheets("RecruiterSpc") 

    Set shtDest(1) = Sheets("Extract_Recrt") 
    Set shtDest(2) = Sheets("Extract_SrRecrt") 
    Set shtDest(3) = Sheets("Extract_RecrtSpc") 

    destRow = 2 'start copying to this row 

    startdate = CDate(InputBox("Input desired start date for report data")) 
    enddate = CDate(InputBox("Input desired end date for report data")) 
     If IsDate(stardate) = False Then Exit Sub 
    'don't scan the entire column... 
    Set rng(1) = Application.Intersect(shtSrc1.Range("A:A"), shtSrc1.UsedRange) 
    Set rng(2) = Application.Intersect(shtSrc2.Range("A:A"), shtSrc2.UsedRange) 
    Set rng(3) = Application.Intersect(shtSrc3.Range("A:A"), shtSrc3.UsedRange) 

      For i = LBound(rng) To UBound(rng) 
       For Each c In rng(i).Cells 
        If c.Value >= startdate And c.Value <= enddate Then 

         c.Offset(0, 0).Resize(1, 25).Copy _ 
             shtDest(i).Cells(destRow, 1) 
         destRow = destRow + 1 

        End If 
       Next 
      Next i 
     End Sub