Excel VBA find string and paste row

Question

Hi,

The excel project I am working has been changed from a daily work roster to  weekly. I am working with a userform with a save button called "ComSave" which saves data to work sheets. What I am attempting to do is find a value on that sheet and copy and paste the row that contains that value. My problem is that a row can contain the value I am lookin for several times and I only want the row to be copy and pasted once. The sheets that contains the value is named "UnitA" the sheet I require the row to be pasted to is named "Patrol". The values I am searching for are "SA64" and "SA69". The data input from the userform look like this (below) on Sheet "UnitA" the range of the page A1:P35.

With Forum Help (thanks Rich) i previously used this code to copy a cell with the value "SA64" and 3 cells to the right. I dont have the knowledge to amend the code my new requirements. Lastly I want the code to run from within the Private Sub ComSAVE_Click(). Thanks for your help and time in advance. Gerry

Option Explicit
Dim C As Range
Dim rngCopyRange As Range
Dim FirstAddress As String
Dim shtSheet1 As Worksheet
Dim shtSheet2 As Worksheet
Dim lngSheet2LastRow As Long
' ***************************************************************
' Find All SA64 Values And Copy That Cell + Three Cells To the
' Right To Sheet 2
' ***************************************************************
Public Sub FindSA64()

Set shtSheet1 = Sheets("UnitA")
Set shtSheet2 = Sheets("Patrol")
' ***************************************************************
' Assume Column A Always Has Data
' ***************************************************************
lngSheet2LastRow = shtSheet2.Cells(Rows.Count, "A").End(xlUp).Row

' ***************************************************************
' Change Sheet1 Range to Your Requirements Or Make It Dynamic
' A1:K500 Is Only For Demo Purposes
' ***************************************************************
With shtSheet1.Range("A1:P35")
    Set C = .Find("SA64", LookIn:=xlValues)
    If Not C Is Nothing Then
        FirstAddress = C.Address
        Call CopyData
        Set C = .FindNext(C)
        Do While Not C Is Nothing And C.Address <> FirstAddress
            Call CopyData
            Set C = .FindNext(C)
        Loop
    End If
End With

End Sub

Public Sub CopyData()
lngSheet2LastRow = lngSheet2LastRow + 1
Set rngCopyRange = Range(C, C.Offset(0, 3))
rngCopyRange.Copy shtSheet2.Cells(lngSheet2LastRow, 1)
End Sub

Unit

Personnel

Monday

Tuesday

Wednesday

Thursday

Friday

Saturday

Sunday

03/12/2012

4pm-2am

13/03/2012

Rest

14/03/2012

Rest

15/03/2012

Rest

16/03/2012

Rest

17/03/2012

7am-5pm

18/03/2012

7am-3pm

A1

Per 1

Dayroom

Dayroom

Dayroom

Dayroom

Dayroom

A1

Per 2

SA64

A1

Per 3

SA60

SA60

SA60

SA60

SA60

SA60

A1

Per 4

SA69

SA69

SA69

SA69

SA69

SA69

SA64

A1

Per 5

A1

Per 6

SA64

A1

Per 7

SA65

RT3

A1

Per 8

SA64

SA64

A1

Per 9

A1

Per 10

SA65

RT1

A1

Per 11

A1

Per 12

A1

Per 13

SA64

SA64

A1

Per 14

SA64

SA64

A1

Per 15

A1

Per 16

Inv

Inv

Inv

Inv

Inv

Inv

Answer 1

See if these changes work.  I simplified the code a little bit by eliminating the Sub CopyData.

Option Explicit
' ***************************************************************
' Find All SA64 Values And Copy That Cell + Three Cells To the
' Right To Sheet 2
' ***************************************************************
Public Sub FindSA64()
Dim C As Range
Dim rngCopyRange As Range
Dim FirstAddress As String
Dim shtSheet1 As Worksheet
Dim shtSheet2 As Worksheet
Dim lngSheet2LastRow As Long
Dim lngSheet2NewRow As Long
Dim LastCopyRow As Integer
Set shtSheet1 = Sheets("UnitA")
Set shtSheet2 = Sheets("Patrol")
' ***************************************************************
' Assume Column A Always Has Data
' ***************************************************************
lngSheet2LastRow = shtSheet2.Cells(Rows.Count, "A").End(xlUp).Row
lngSheet2NewRow = lngSheet2LastRow + 1
' ***************************************************************
' Change Sheet1 Range to Your Requirements Or Make It Dynamic
' A1:K500 Is Only For Demo Purposes
' ***************************************************************
With shtSheet1.Cells
    LastCopyRow = 0
    Set C = .Find("SA64", _
       LookIn:=xlValues, _
       Lookat:=xlWhole, _
       SearchOrder:=xlByRows)
    If Not C Is Nothing Then
        FirstAddress = C.Address
        Set C = .FindNext(C)
        Do
            If C.Row <> LastCopyRow Then
               C.EntireRow.Copy _
                  Destination:=shtSheet2.Rows(lngSheet2NewRow)
                  lngSheet2NewRow = lngSheet2NewRow + 1
               LastCopyRow = C.Row
             End If
             Set C = .FindNext(C)
        Loop While Not C Is Nothing And C.Address <> FirstAddress
    End If
End With
End Sub

---

jdweng

Answer 2

Great Thanks works a treat. Can I bother you for one other thing.

How do I add a second value "SA69" to the search.

Thanks

Gerry

Answer 3

Are you looking for rows that have both SA69 and SA64; or just either one.  If yo uare looking for either one I recommend run the code twice.  You can setup an array like this

CourseArray = Array("SA64","SA69")

for each Course in CourseArray

   "enter the code from above except make this one change

   Set C = .Find(Course, _
       LookIn:=xlValues, _
       Lookat:=xlWhole, _
       SearchOrder:=xlByRows)

  

next Course

---

jdweng

Answer 4

Thats great.

Thanks again for your time.

Gerry

Answer 5

Sorry I have to come back to you again. In my Worksheets there will be rows which contain  "SA64" or "SA69" and rows that will have the two values "SA64" & "SA69" IN OTHER WORDS I AM LOOKING FOR BOTH

The first code works great thank you but I am new to VBA and cant figure out where to insert

CourseArray = Array("SA64","SA69")

for each Course in CourseArray

Gerry

Answer 6

The code it is presently will print a row that has both SA64 and SA69 twice.

Option Explicit
' ***************************************************************
' Find All SA64 Values And Copy That Cell + Three Cells To the
' Right To Sheet 2
' ***************************************************************
Public Sub FindSA64()
Dim C As Range
Dim rngCopyRange As Range
Dim FirstAddress As String
Dim shtSheet1 As Worksheet
Dim shtSheet2 As Worksheet
Dim lngSheet2LastRow As Long
Dim lngSheet2NewRow As Long
Dim LastCopyRow As Integer
Set shtSheet1 = Sheets("UnitA")
Set shtSheet2 = Sheets("Patrol")
' ***************************************************************
' Assume Column A Always Has Data
' ***************************************************************
lngSheet2LastRow = shtSheet2.Cells(Rows.Count, "A").End(xlUp).Row
lngSheet2NewRow = lngSheet2LastRow + 1
' ***************************************************************
' Change Sheet1 Range to Your Requirements Or Make It Dynamic
' A1:K500 Is Only For Demo Purposes
' ***************************************************************
Dim CourseArray() as variant
Dim Course as string
CourseArray = Array("SA64","SA69")
With shtSheet1.Cells
   for each Course in CourseArray
       LastCopyRow = 0
       Set C = .Find(Course, _
          LookIn:=xlValues, _
          Lookat:=xlWhole, _
          SearchOrder:=xlByRows)
       If Not C Is Nothing Then
          FirstAddress = C.Address
          Set C = .FindNext(C)
          Do
            If C.Row <> LastCopyRow Then
               C.EntireRow.Copy _
                  Destination:=shtSheet2.Rows(lngSheet2NewRow)
                  lngSheet2NewRow = lngSheet2NewRow + 1
               LastCopyRow = C.Row
             End If
             Set C = .FindNext(C)
          Loop While Not C Is Nothing And C.Address <> FirstAddress
       End If
End With
End sub

---

jdweng

Answer 7

Thanks Joel,

I was unsure if you would get my follow up question. Thanks for getting back to me. I was unsure that by marking the question as answered if it would end the post. I subsequently got the following advise on the code. It was not my intention to look for an answer in two forums but by making the wrong assumption I have.

To make the code find all occurrences, change

CODE: SELECT ALL

            If Not C Is Nothing Then
                FirstAddress = C.Address
                Set C = .FindNext(C)
                Do


to

CODE: SELECT ALL

            If Not C Is Nothing Then
                FirstAddress = C.Address
                Do


i.e. delete the first occurrence of the line Set C = .FindNext(C).

Acknowledgement to Hans V

Gerry