[SOLVED] Need Excel Code to copy one row to another sheet if row contains certian TEXT

[Drscott21]

I am trying to figure out how to copy Rows Containing 2-3 Surg or 2-3 Sicu on Sheet named Admissions, and have it automatically paste the entire row on sheet named Surg Adm. I am going crazy over this I have tried multiple solutions that I found when I googled it. But nothing is working. I have uploaded the workbook so you can see what I am working with.

[JOHN H. DAVIS]

Unfortunately I couldn't access your attachment. However, maybe this will help. Note it assumes the text strings are in Column "A".

Sub Drscott21()
Dim i As Long, ws As Worksheet, ws2 As Worksheet
Set ws = Sheets("Admissions")
Set ws2 = Sheets("Surg Adm")
With ws
    For i = 2 To .Range("A" & Rows.Count).End(3).row
        If .Cells(i, "A") Like "*2-3 Surg*" Or .Cells(i, "A") Like "*2-3 Sicu*" Then
            .Rows(i).Copy ws2.Range("A" & Rows.Count).End(3)(2)
        End If
    Next i
End With
End Sub

[Drscott21]

Thanks, unfortunately it didn't work the text strings are in Column "D". I tried to change the "A" to "D" and it didn't work. I need to copy the entire and then paste it on the sheet named "Surg Adm".

I Attached the file again you have to save it first and then try to open it.

[JOHN H. DAVIS]

This works for me on your sample.

Sub Drscott21()
Dim i As Long, ws As Worksheet, ws2 As Worksheet
Set ws = Sheets("Admission")
Set ws2 = Sheets("Surg Adm")
With ws
    For i = 2 To .Range("D" & Rows.Count).End(3).row
        If .Cells(i, "D") Like "*2-3 surg*" Or .Cells(i, "D") Like "*2-3 sicu*" Then
            .Rows(i).Copy ws2.Range("A" & Rows.Count).End(3)(2)
        End If
    Next i
End With
End Sub

[Drscott21]

That does seem to work but how can I make it copy and then paste the all of the rows that contain "2-3 Surg" or "2-3 Sicu"? Because it is currently only copying and then pasting one row.

[JOHN H. DAVIS]

When I tested on your sample there were 12 rows meeting your criteria. They all were copied. Not sure what you mean when you say only one row was pasted?

[Drscott21]

When I run the Marco it is only copying one row and pasting it on the Sheet named "Surg Adm".

See Attachement.

[bbrock316]

Watch this, I believe the code is a bit different, but it should do what you want.

https://www.youtube.com/watch?v=fxgQm32sBeI

[Winon]

Hello Drscott21,

Which version of Excel are you actually using, since the uploaded sample Workbook is in Excel 2003 format, and not Excel 2007 or later, which makes a big difference. Your profile shows that you are using Excel 2010. Please try the code provided on that platform.

Regards.

[Drscott21]

Hello Winon,
I am using Excel 2010. I had to upload an older version so those helping me could see it.

[jaslake]

Hi Drscott21

In your Thread you've dealt with...

Rows Containing 2-3 Surg or 2-3 Sicu

Where do the other items go? Let's deal with all of them...tell me where and we'll put them there.

Row\Col	A	B	C
1	Service		Go to WS???
2	N42-1B
3	2-3 surg		Goes to Surg Adm
4	43-1
5	8-1
6	2-3 med
7	2-3 micu
8	4-4 sarrtp
9	2-3 sicu		Goes to Surg Adm
10	Ed med
11	N42-2C

[jaslake]

Hi Drscott21

This Code in the attached appears to work on your Sample Data...CTRL + x will fire the Code...however, as I suggested in my previous Post...

Where do the other items go? Let's deal with all of them...tell me where and we'll put them there...

Option Explicit

Sub Split_Service()
   Dim ws           As Worksheet
   Dim ws1          As Worksheet
   Dim LR           As Long

   Application.ScreenUpdating = False
   Set ws = Sheets("Admission")
   Set ws1 = Sheets("Surg Adm")
   With ws1
      .UsedRange.Offset(1, 0).ClearContents
   End With

   With ws
      LR = .Range("D" & .Rows.Count).End(xlUp).Row
      .Range("A1:P" & LR).AutoFilter Field:=4, Criteria1:= _
                                     "=2-3 sicu", Operator:=xlOr, Criteria2:="=2-3 surg"
      .Range(.Cells(2, 1), .Cells(LR, "P")).SpecialCells(xlCellTypeVisible).EntireRow.Copy
      ws1.Range("A2").PasteSpecial (xlPasteColumnWidths)
      ws1.Range("A2").PasteSpecial (xlPasteValues)
      .AutoFilterMode = False
   End With
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
End Sub

[Drscott21]

The other items need to go to the appropriate worksheet. "Service" is a header so that is already on each worksheet. 8-1, 8-3, Ed Psyc, and 4-4 sarrtp need to go to worksheet named "Psy Adm". 2-3 med, 2-3 micu and ed med need to go to worksheet named "Med Adm". Lastly, N42-2C, N42-1B and 43-1 need to go to worksheet named "Gec Adm".

Thank You for you help I greatly appreciate it.

[jaslake]

Hi Drscott21

Try this Code in the attached...CTRL + x will fire the Code.

Option Explicit

Sub Split_Service()
   Dim ws           As Worksheet
   Dim ws1          As Worksheet
   Dim LR           As Long

   Application.ScreenUpdating = False
   Set ws = Sheets("Admission")

   With ws
      LR = .Range("D" & .Rows.Count).End(xlUp).Row
      .Range("A1:O" & LR).AutoFilter Field:=4, Criteria1:= _
                                     "=2-3 sicu", Operator:=xlOr, Criteria2:="=2-3 surg"

      If .Columns(4).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
         Set ws1 = Sheets("Surg Adm")
         With ws1
            .UsedRange.Offset(1, 0).ClearContents
         End With

         .Range(.Cells(2, 1), .Cells(LR, "O")).SpecialCells(xlCellTypeVisible).EntireRow.Copy
         ws1.Range("A2").PasteSpecial (xlPasteColumnWidths)
         ws1.Range("A2").PasteSpecial (xlPasteValues)
      End If
      .AutoFilterMode = False


      .Range("A1:O" & LR).AutoFilter Field:=4, Criteria1:= _
                                     Array("4-4 sarrtp", "8-1", "8-3", "ed psyc"), Operator:=xlFilterValues
      
      If .Columns(4).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
         Set ws1 = Sheets("Psy Adm")
         With ws1
            .UsedRange.Offset(1, 0).ClearContents
         End With

         .Range(.Cells(2, 1), .Cells(LR, "O")).SpecialCells(xlCellTypeVisible).EntireRow.Copy
         ws1.Range("A2").PasteSpecial (xlPasteColumnWidths)
         ws1.Range("A2").PasteSpecial (xlPasteValues)
      End If
      .AutoFilterMode = False


      .Range("A1:O" & LR).AutoFilter Field:=4, Criteria1:= _
                                     Array("2-3 med", "2-3 micu", "ed med"), Operator:=xlFilterValues

      If .Columns(4).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
         Set ws1 = Sheets("Med Adm")
         With ws1
            .UsedRange.Offset(1, 0).ClearContents
         End With

         .Range(.Cells(2, 1), .Cells(LR, "O")).SpecialCells(xlCellTypeVisible).EntireRow.Copy
         ws1.Range("A2").PasteSpecial (xlPasteColumnWidths)
         ws1.Range("A2").PasteSpecial (xlPasteValues)
      End If
      .AutoFilterMode = False

      .Range("A1:O" & LR).AutoFilter Field:=4, Criteria1:= _
                                     Array("N42-2C", "N42-1B", "43-1"), Operator:=xlFilterValues

      If .Columns(4).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
         Set ws1 = Sheets("Gec Adm")
         With ws1
            .UsedRange.Offset(1, 0).ClearContents
         End With

         .Range(.Cells(2, 1), .Cells(LR, "O")).SpecialCells(xlCellTypeVisible).EntireRow.Copy
         ws1.Range("A2").PasteSpecial (xlPasteColumnWidths)
         ws1.Range("A2").PasteSpecial (xlPasteValues)
      End If
      .AutoFilterMode = False

   End With
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
End Sub