VBA代碼從多個表格提取到新的多個表格

Question

我有點新手VBA用戶，並且我創建了一個具有多個選項卡的用戶窗體的工作簿。當用戶選擇適當的選項卡並輸入數據時，它將被轉移到適用的工作表中。我在工作表上有一個命令按鈕，點擊它時會提示日期範圍，然後我希望它從每個適用的工作表中提取傳輸的數據，並將其放在每個用戶的單獨的新工作表上（因爲每個人的數據都不相同）。我編譯的下面的VBA代碼沒有正確處理。相反，它只從一個工作表中提取數據，並將其放在所有新的單個工作表上。

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