VBA Code That Extracts From Multiple Sheets to New Multiple Sheets

0
votes

I am somewhat of a novice VBA user and I have created a workbook that has a Userform with several tabs. When the user selects the appropriate tab and inputs data it gets transferred to the applicable worksheet. I have a command button on a worksheet that when clicked it prompts for a date range and then I want it to extract the transferred data from each applicable worksheet and place it onto separate new worksheets for each user (because everyone's data is different). The below VBA code I have compiled is not processing correctly. Instead it only pulls data from one worksheet and puts it on all of the new individual worksheets. 

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

Can anyone please show me what I'm doing wrong and how to fix it.

2
vbaexcel

2 Answers

1
votes

Firstly it looks like you are setting the rng variable and then overwriting it. I would change the code to something like this to accommodate the 3 rng variables that seem to be needed.

ie,

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)

Then use a for loop to loop through each range you just set. The complete code is below for reference.

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
0
votes

not so sure about your needs but you can try this

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