VBA - Loop through range, then copy range values into other sheet based on condition

[The Great SrH]

Hi guys,


I'm hoping somebody can help me with a code I need. I've attempted it below but it doesn't work, and it's probably completely wrong!


I have a worksheet called "Form" where the user will input data on a row by row basis. The maximum entries they can put on the sheet are 15 (15 rows) and the first row is A3-I3 (last row A17-I17).


I then have 2 replica worksheets which i want the code to output to - one called DFU and the other PeopleSoft.


I need the code to go down the "Form" worksheet and if Column B's content equals DFU, it will move that row to the "DFU" worksheet. If Column B equals PeopleSoft, it will move that row to the "PeopleSoft" worksheet.


When moving to the other worksheet, i need it to find the first available row in the range A3-I17.


Thanks for any help you can provide!

Sub test2()
Dim LR As Long, i As Long
With Sheets("Form")
    LR = .Range("A17" & Rows.Count).End(xlUp).row
    For i = 1 To LR
        If .Range("B" & i).Value = "DFU" Then
            .Range("A:I" & i).Copy
            Sheets("DFU").Range("A3:A17" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
End With

End Sub

 

[vcoolio]

Hello SrH,

A few questions first:-

- Your data starts in Row3 of the "Form" sheet. Does this mean that you have headings in Row2?
- Are there headings in Row2 of both the destination sheets?
- In the destination sheets, is there any data from Row18 on?

Cheerio,
vcoolio.

 

[The Great SrH]

Hello SrH,

A few questions first:-

- Your data starts in Row3 of the "Form" sheet. Does this mean that you have headings in Row2?
- Are there headings in Row2 of both the destination sheets?
- In the destination sheets, is there any data from Row18 on?

Cheerio,
vcoolio.

Thanks for the response!
Row 1 basically contains a title to the form in large font
Row 2 is the headings
Row 3 - 17 is where the user inputs the data
Row 18 is a total tab containing formulas
Row 19 is blank
Row 20-21 are some governance details such as Date
The additional destination sheets will be exactly the same as "Form"

 

[vcoolio]

Hello SrH,


See if the following code works for you:-

Sub Test()

    Dim ar As Variant, i As Integer
    Dim ws As Worksheet: Set ws = Sheets("Form")
    ar = [{"DFU","PeopleSoft";"DFU","PeopleSoft"}]

Application.ScreenUpdating = False

    For i = 1 To UBound(ar, 2)
        With ws.Range("B2", Range("B" & Rows.Count).End(xlUp))
                    .AutoFilter 1, ar(2, i)
                    .Offset(1).EntireRow.Copy Sheets(ar(1, i)).Range("A17").End(3)(2)
                    .AutoFilter
        End With
 Next i
    
Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.

 

[The Great SrH]

Thanks for this

Unfortunately, it doesn't seem to work.
I'm also concerned that it will copy the entire row rather than just columns A to I

 

[vcoolio]

Hello SrH,

I've tested the code in a sample of how I would assume your workbook to be set out, based on your above descriptions, and it works flawlessly.

There may be something else at play that may be causing a problem so I recommend that you upload a sample of your workbook to a file sharing site and then paste the link to your file back here. Please ensure that your sample is an exact replica of your actual workbook and if your data is sensitive then please use dummy data.

Cheerio,
vcoolio.

 

[The Great SrH]

Hello SrH,

I've tested the code in a sample of how I would assume your workbook to be set out, based on your above descriptions, and it works flawlessly.

There may be something else at play that may be causing a problem so I recommend that you upload a sample of your workbook to a file sharing site and then paste the link to your file back here. Please ensure that your sample is an exact replica of your actual workbook and if your data is sensitive then please use dummy data.

Cheerio,
vcoolio.

Apologies but im not able to upload at the moment (restricted servers).

It fails here:

.Offset(1).EntireRow.Copy Sheets(ar(1, i)).Range("A17").End(3)(2)

Would this be because there isnt data in A17?

One thing I may not have mentioned is the user may not necessarily go up to Row 17. The data i'm using is currently in A3-I8

 

[vcoolio]

What does the actual error say?

 

[The Great SrH]

Sorry - I realised my issue was actually here:

    ar = [{"DFU","PeopleSoft";"DFU","PeopleSoft"}]

Whilst the sheets are called "DFU" and "PeopleSoft", the cell contents in Column B are:
Mortgage DFU refund - 33/29
PeopleSoft Cashback - 161128
PeopleSoft ERC - 101110
PeopleSoft MEAF - 161111
PeopleSoft Interest - 101105

I thought it would be easy for me with the code to change this, but im clearly not capable haha!

 

[vcoolio]

Hello SrH,

Try changing this line:-

.AutoFilter 1,  ar(2, i)

to

.AutoFilter 1, "*" & ar(2, i) & "*"

and let us know the result.

Cheerio,
vcoolio.