Copying Cells From One Sheet To Another Based On Certain Criteria

[mlarson]

Hi there, I hope you can help me with this question. I'm not sure how to post an Excel spreadsheet but it may not be needed for this question anyway. Thanks in advance for your help!

The spreadsheet would show Column A cells with either the word "yes" or "no." Same with Column B, C, D...M. Each column goes down 350 rows.

Here are the actions I'd like to be able to accomplish...

First Group:
On "Sheet1", find the first "yes" that appears (going from top to bottom) in Column A.
Copy cells from columns P-AH on that same row the first "yes" appears.
Paste those cells on "Sheet2" in B1-T1.
On "Sheet1", find the first "yes" that appears (going from top to bottom) in Column B.
Copy cells from columns P-AH on that same row the first "yes" appears.
Paste those cells on "Sheet2" in B2-T2.
Repeat for columns C, D, E...M (first "yes" in each column, so Column M results will go to B13-T13).

Second Group:
On "Sheet1", find the second "yes" that appears (going from top to bottom) in Column A.
Copy cells from columns P-AH on that same row the second "yes" appears.
Paste those cells on "Sheet2" in B14-T14.
On "Sheet1", find the first "yes" that appears (going from top to bottom) in Column B.
Copy cells from columns P-AH on that same row the first "yes" appears.
Paste those cells on "Sheet2" in B26-T26.
Repeat for columns C, D, E...M with the third "yes" for each.

Third Group:
On "Sheet1", find the fourth "yes" that appears (going from top to bottom) in Column A.
Copy cells from columns P-AH on that same row the fourth "yes" appears.
Paste those cells on "Sheet2" in B27-T27.
On "Sheet1", find the fifth "yes" that appears (going from top to bottom) in Column B.
Copy cells from columns P-AH on that same row the fifth "yes" appears.
Paste those cells on "Sheet2" in B39-T39.
Repeat for columns C, D, E...M with the second "yes" for each.

In total there will be 39 rows of data entered on "Sheet2."

Thanks again!

 

[mlarson]

Hi Fluff,

Yes, that is what I want to happen. However, here are the results I'm getting, in order of columns (A, B, C...M):

Row 2: 1st, 1st, 1st, 1st, 1st, 1st, 1st, then the "no" directly above/before the first "yes" for H-M

Row 3: 2nd, 1st, 2nd, 2nd, 2nd, 2nd, the "no" directly above/before the second "yes" but after the first "yes", 1st, 1st, 1st, 1st, 1st, 1st

Row 4: 4th, 5th, 3rd, 3rd, 3rd, the "no" directly above/before the third "yes" but after the second "yes", 2nd, 2nd, 2nd, 2nd, 2nd, 2nd, 2nd

 

[Fluff]

This will correct some of the problem, but not sure why you're getting some no in there.

Sub copyData()

   Dim Cl As Range
   Dim Col As Long
   Dim Cnt As Long
   Dim Rw As Long
   Dim Ary As Variant
   Dim Clm As Long
   
   With Sheets("Active")
         Clm = 2
      For Col = 1 To 13
         Rw = 2
         Cnt = 0
         If Col = 1 Then
            Ary = Array(1, 2, 4)
         ElseIf Col = 2 Then
            Ary = Array(1, 1, 5)
         Else
            Ary = Array(1, 3, 2)
         End If
         .Columns(Col).AutoFilter 1, "Yes"
         For Each Cl In .Range(.Cells(2, Col), .Cells(Rows.Count, Col).End(xlUp)).SpecialCells(xlVisible)
            Cnt = Cnt + 1
            If Cnt = Ary(0) Then
               .Range("P" & Cl.Row).Resize(, 19).Copy Sheets("Sheet2").Cells(Rw, Clm)
               Rw = Rw + 1
            End If
            If Cnt = Ary(1) Then
               .Range("P" & Cl.Row).Resize(, 19).Copy Sheets("Sheet2").Cells(Rw, Clm)
            End If
            If Cnt = Ary(2) Then
               If Col > 2 Then Rw = Rw + 1
               .Range("P" & Cl.Row).Resize(, 19).Copy Sheets("Sheet2").Cells(Rw, Clm)
               If Col < 3 Then
                  Rw = Rw + 1
               Else
                  Rw = Rw - 1
               End If
            End If
            If Cnt = WorksheetFunction.Max(Ary) Then Exit For
         Next Cl
        [COLOR=#ff0000] Clm = Clm + 20[/COLOR]
         .AutoFilterMode = False
      Next Col
   End With
   
End Sub

Reduce the size of the VBE window so that you can see the main sheet, then In the VBE put the cursor on the line in red & press F9, this sets a breakpoint (That line should get a brown back fill)
press F5 & the code will run to the break point Check that col A is filtered & only Yes is visible, then press F5 again & col B should be filtered. Do this until the macro finishes.
Every time the code stops is there only 1 column filtered? & is it filtered correctly?

 

[mlarson]

Every time the code stops is there only 1 column filtered? & is it filtered correctly?

Yes, each time the code stops there is 1 and only 1 column filtered, the correct column each time it runs. And it only shows "yes" in the cells.

 

[Fluff]

Do you have any merged cells?

 

[mlarson]

No merged cells.

 

[Fluff]

In that case I don't understand, why you are getting "no" values in the output.
That said I've realised that there is a slight problem with the last code I supplied, which is rectified here.

Sub copyData()

   Dim Cl As Range
   Dim Col As Long
   Dim Cnt As Long
   Dim Rw As Long
   Dim Ary As Variant
   Dim Clm As Long
   
   With Sheets("Active")
         Clm = 2
      For Col = 1 To 13
         Rw = 2
         Cnt = 0
         If Col = 1 Then
            Ary = Array(1, 2, 4)
         ElseIf Col = 2 Then
            Ary = Array(1, 1, 5)
         Else
            Ary = Array(1, 3, 2)
         End If
         .Columns(Col).AutoFilter 1, "Yes"
         For Each Cl In .Range(.Cells(2, Col), .Cells(Rows.Count, Col).End(xlUp)).SpecialCells(xlVisible)
            Cnt = Cnt + 1
            If Cnt = Ary(0) Then
               .Range("P" & Cl.Row).Resize(, 19).Copy Sheets("Sheet2").Cells(Rw, Clm)
               Rw = Rw + 1
            End If
            If Cnt = Ary(1) Then
               .Range("P" & Cl.Row).Resize(, 19).Copy Sheets("Sheet2").Cells(Rw, Clm)
               Rw = Rw + 1
            End If
            If Cnt = Ary(2) Then
               If Col > 2 Then Rw = Rw + 1
               .Range("P" & Cl.Row).Resize(, 19).Copy Sheets("Sheet2").Cells(Rw, Clm)
               If Col < 3 Then
                  Rw = Rw + 1
               Else
                  Rw = Rw - 1
               End If
            End If
            If Cnt = WorksheetFunction.Max(Ary) Then Exit For
         Next Cl
         Clm = Clm + 20
         .AutoFilterMode = False
      Next Col
   End With
   
End Sub

 

[mlarson]

Thank you for the updated code, Fluff. And thank you for trying on the "no" output. It is strange. I'll try to figure out a way to work around it.

 

[Fluff]

Would you be willing to share your file?
If so you can upload it to OneDrive, or Dropbox, mark it for sharing & post the link here.

 

[mlarson]

My Dropbox is currently giving me some issues but I will upload it and post a link once it's working properly again. Thank you!

 

[mlarson]

Hi Fluff, I wanted to follow-up on this as I said I would. My Dropbox is still giving me fits but I think I have a solution for what I'm trying to do. I must say, your help was very beneficial to me and I feel like I've grown a lot in my understanding of Excel based on our brief conversations! Thank you for that and I hope you have a great week!