Find and copy several values

[Jorispk]

Good afternoon,

I'm trying to make a very complex VBA code in excel but so far it is not working as it should.

Information:
In excel I get a list wich is containing over 300 rows of information on 1 sheet with each different statements. (Used for weight calculation)

Each statements consists of 3 rows, with on the first row in column D/E(combined cells) style 1, Column G style and on the second row the quantity in column S/T/U(Combined cells).


imageshack.us/photo/my-images/843/excelsample1.jpg/


The styles vary between 20 styles but for this style A and B is enough.


imageshack.us/photo/my-images/833/excelsample2.jpg/


What I need is a VBA code that Finds on Column D/E all the rows that are Style A and than looks at column G for style C.

Then It should Copy all results with in column D/E style A and Column Style C to sheet 1, with in the copy both styles and quantity.

For 2nd It should find Style A and in column G style D and copy both styles and quantity to sheet 2.

Etc. When I have the code for 1 it's easy to do the others.


I have now this code but with it I can only copy style 1 but I need to copy Style 2 and the quantity to.

Private Sub Copy_To_Another_Sheet_1()
    Dim FirstAddress As String
    Dim MyArr As Variant
    Dim Rng As Range
    Dim Rcount As Long
    Dim I As Long
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    MyArr = Array("A")
    With Sheets("Sheet1").Range("D1:E30")
        Rcount = 0
        For I = LBound(MyArr) To UBound(MyArr)
            Set Rng = .Find(What:=MyArr(I), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rcount = Rcount + 1
                    Rng.Copy Worksheets(Sheet2).Range("A" & Rcount)
                    Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next I
    End With
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Hope you guys understand what I mean and thanks in advance for your help.

 

[Brianwarnock]

I don't know what you actually want to copy to the other sheets but my approach would be like below. note that thecopy statements rely on there being data in cilumn A if not a different approach to the lastrow on the receiving sheets is required.

Brian

Sub test()

'Brian Warnock November 2011

Dim lastrow As Long
Dim r As Long
Dim ws As Worksheet

Set ws = Sheets("sheet1")
lastrow = ws.UsedRange.Rows.Count

For r = 1 To lastrow
    If ws.Cells(r, "D") <> "a" Then GoTo nextrow
    Select Case ws.Cells(r, "G")
        Case "c"
            Rows(r).Copy Worksheets("sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Case "d"
            Rows(r & ":" & r + 2).Copy Worksheets("sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
     ' the above shows how to copy the 3 rows from the original that make up your record
        Case Else
    End Select
    
nextrow:
    Next r
End Sub

 

[Jorispk]

Thanks for the reply, will try this tomorrow.

Look (suppose the code works fine)


In row 2 style A in column D/E is found and style C in column G is found.

The program needs to copy Style A, Style C from row 2 and most important the quantity located in row 3/4 and Column S/T/U(merged cells) to an other worksheet in cells A1, B1 and C1.

Than the program looks for the Next Style A in column D/E and style C in column G. This could be in say row 11(D11/E11) and G11 than it needs to copy D11/E11, G11 and S/T/U 12/13(column/row) to the same worksheet as before on cells A2, B2 and C2.

And this proces needs to be continued till the last Style A and style C are copied from the entire list.

Hope this is clear It's kind of a complex situation.

 

[Brianwarnock]

Ah!

What my code does is show how to do all the searches you mentioned you will need in one pass, but it does copy entire rows.

I've not handled merge Cells as I consider them an aberration so it may take a while to look at this especially as i have to go now.

Brian

 

[Jorispk]

Thank you very much!!

This is already working fine! It sorts out the different lines perfectly ^^.

I can work with this results thank you!

Edit*

I can't get it work for a 2nd subject

Sub test()
'Brian Warnock November 2011
Dim lastrow As Long
Dim r As Long
Dim ws As Worksheet
Set ws = Sheets("List")
lastrow = ws.UsedRange.Rows.Count
For r = 1 To lastrow
If ws.Cells(r, "D") <> "A" Then GoTo nextrow
    Select Case ws.Cells(r, "G")
        Case "C"
            Rows(r & ":" & r + 2).Copy Worksheets("C").Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
        Case "D"
            Rows(r & ":" & r + 2).Copy Worksheets("D").Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
     ' the above shows how to copy the 3 rows from the original that make up your record
        Case Else
    End Select
    If ws.Cells(r, "D") <> "B" Then GoTo nextrow
    Select Case ws.Cells(r, "G")
        Case "E"
            Rows(r & ":" & r + 2).Copy Worksheets("E").Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
     ' the above shows how to copy the 3 rows from the original that make up your record
        Case Else
    End Select
nextrow:
    Next r
End Sub

Need to seperate more than 100 different codes for this. So it would be nice if the code is extendable ^^

 

[Brianwarnock]

After your previous post I changed my code.

Whether you use If ..Then Block code or Select Case is dependent on your preference but for multiple values , whether horizontal or vertical I prefer Select Case

ie Case 1,3,5,6
Do action

or
Case 1
do action
Case 2
do action
Case
etc

my approach is shown below, it is not really copy and paste code as you will need to use your names and criteria. Although the code may be extensive it is very simple.

Brian

Sub test()

'Brian Warnock November 2011

Dim LastRow As Long
Dim newRow2 As Long
Dim newRow3 As Long
etc for all worksheets required
Dim r As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
etc for all worksheets required

Set ws1 = Sheets("sheet1")
LastRow = ws1.UsedRange.Rows.Count
Set ws2 = Sheets("sheet2")
Set ws3 = Sheets("sheet3")
newRow2 = 1
newRow3 = 1
etc for all worksheets required
' If the intention is to add to existing data then use
'newRow2 = ws2.Range("A65536").End(xlUp).Row + 1
'newRow3 = ws3.Range("A65536").End(xlUp).Row + 1


For r = 1 To LastRow - 2 Step 3 ' only every third row is tested
    If ws1.Cells(r, "D") = "a" Then 
    Select Case ws1.Cells(r, "G")
        Case "c"
            ws2.Cells(newRow2, "A") = ws1.Cells(r, "D")
            ws2.Cells(newRow2, "B") = ws1.Cells(r, "g")
            ws2.Cells(newRow2, "C") = ws1.Cells(r + 2, "I")
            newRow2 = newRow2 + 1
        Case "d"
            ws3.Cells(newRow3, "A") = ws1.Cells(r, "D")
            ws3.Cells(newRow3, "B") = ws1.Cells(r, "g")
            ws3.Cells(newRow3, "C") = ws1.Cells(r + 2, "I")
            newRow3 = newRow3 + 1

More cases as required

        Case Else
    End Select
    ElseIf ws1.Cells(r, "D") = "b" Then 
         Select Case ws1.Cells(r, "G")
etc until all combinations are covered

    EndIf
    
    Next r
End Sub

 

[Jorispk]

thanks this works great !!