VBA Loop and copy data

[silvertyphoon1]

I have a sheet called "Hours" and another one called "Name". When a button is pressed the sequence of events should follow:

1. A loop searches through Column "B" on the Hours sheet and looks for the word "Alex". If it finds "Alex" it looks in the same row but Column D for the word "Submitted".

If it finds both "Alex" and "Submitted" it continues on down the list. But if it only finds "Alex" the following happens:

The data from that row column "A" is copied to the "Name" sheet in the next blank row in column "A". The data from column "E" of that same row in the Hours sheet is copied to the "Name" sheet on that same row in the "F" column. Lastly the data on that same row from the Hours sheet column "G" is copied to the "name" sheet on the same row column "G".

Once this action is complete the word "Submitted" should be placed in the row for the "Hours" sheet.

The loop continues until it checks all of the names and completes the ones not submitted. If all are submitted it will end - Thanks in advanced!!

 

[Marcelo Branco]

Hi,

Try this macro on a test-workbook

Sub FindCopy()
    Dim wkHours As Worksheet, wkName As Worksheet
    Dim FoundCell As Range, LastCell As Range
    Dim FirstAddr As String
    Dim LRHours As Long, FRName As Long
 
    Set wkHours = Sheets("Hours")
    Set wkName = Sheets("Name")
 
    With wkHours
        LRHours = .Cells(.Rows.Count, "B").End(xlUp).Row
 
        With .Range("B2:B" & LRHours)
            Set LastCell = .Cells(.Cells.Count)
            Set FoundCell = .Find(What:="Alex", after:=LastCell)
 
            If Not FoundCell Is Nothing Then
                FirstAddr = FoundCell.Address
            End If
 
            Do Until FoundCell Is Nothing
                If FoundCell.Offset(, 2) <> "Submitted" Then
                    FoundCell.Offset(, 2) = "Submitted"
                    FRName = wkName.Cells(wkName.Rows.Count, "A").End(xlUp).Row + 1
                    wkName.Range("A" & FRName).Value = FoundCell.Offset(, -1).Value
                    wkName.Range("E" & FRName).Value = FoundCell.Offset(, 3).Value
                    wkName.Range("G" & FRName).Value = FoundCell.Offset(, 5).Value
                End If
 
                Set FoundCell = .FindNext(after:=FoundCell)
 
                If FoundCell.Address = FirstAddr Then
                    Exit Do
                End If
            Loop
        End With
    End With
End Sub

HTH

M.

 

[Marcelo Branco]

oops... i misread your OP. I thaught you had many instances of Alex, some Submitted, others no.

Wait for a new version

M.

 

[Marcelo Branco]

Hi,

Assuming data in sheet Hours begin at row 2 (adjust to suit),
try this one on a test-workbook

Sub FindAndCopy()
    Dim wkHours As Worksheet, wkName As Worksheet
    Dim LRHours As Long, FRName As Long, i As Long
 
    Set wkHours = Sheets("Hours")
    Set wkName = Sheets("Name")
 
    With wkHours
        'Find the last row in sheet Hours
        LRHours = .Cells(.Rows.Count, "B").End(xlUp).Row
 
        'Loop through all names, beginning at row 2. Adjust if needed
        For i = 2 To LRHours
            With .Range("B" & i)
 
                If .Offset(, 2).Value <> "Submitted" Then
                    'Find the first empty row in sheet Name
                    FRName = wkName.Cells(wkName.Rows.Count, "A").End(xlUp).Row + 1
 
                    'Copy data from sheet Hours to sheet Name
                    wkName.Range("A" & FRName).Value = .Offset(, -1).Value
                    'wkName.Range("B" & FRName).Value = .Value
                    wkName.Range("E" & FRName).Value = .Offset(, 3).Value
                    wkName.Range("G" & FRName).Value = .Offset(, 5).Value
 
                    'Update column D of sheet Hours
                    .Offset(, 2).Value = "Submitted"
                End If
 
            End With
        Next i
 
    End With
End Sub

HTH

M.