Question

我有点像新手VBA用户，我创建了一个具有多个标签的Userform的工作簿。当用户选择适当的选项卡并输入数据时，它将被传输到适用的工作表。我在工作表上有一个命令按钮，单击它时会提示输入日期范围，然后我希望它从每个适用的工作表中提取传输的数据，并将其放在每个用户的单独的新工作表中（因为每个人的数据都是不同）。我编译的以下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

首先看起来你正在设置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

Answer 2

不太确定您的需求，但您可以试试这个

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

从多个表格提取到新的多张表格的VBA代码

2 个答案: