Copy name from column to column for respective ID

[k3vsmith]

I want to copy the name in CAM where WBS Element Indicator is C to CAM column where WBS Element Indicator is W. ...On its respective WBS ID.

Instructions:
For column WBS Element Indicator on W and C
Copy name from CAM column on C to CAM column on W for respective project
The number of rows for this report could vary. Maybe do a filter on C and W and then do copy for visible cells?

Uploading TestReport2.xls. Worksheet Test Report is where Im currently at. Worksheet What I want is where I want to be. Highlighted in yellow on What I want is change made.

 

[k3vsmith]

Please assist on VBA code to make this happen. Thanks in advance.

 

[Luke M]

Thank you for an excellent before/after example of what you wanted.
This macro will do what you require.

Sub FindCams()
Dim fWCell As Range
Dim fCCell As Range
Dim firstAdd As String
Dim ws As Worksheet

'Which worksheet are we dealing with?
Set ws = ActiveSheet

Application.ScreenUpdating = False
'Make sure all rows are visible
ws.AutoFilterMode = False
With ws.Range("C:C")
    Set fWCell = .Find(what:="W", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
   
    If fWCell Is Nothing Then
        MsgBox "No cells found with a 'W'."
        Exit Sub
    Else
        firstAdd = fWCell.Address
    End If
   
    'Loop over W cells
    Do
        Set fCCell = .Resize(fWCell.Row).Find(what:="C", after:=fWCell, _
            LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious, MatchCase:=False)
       
        If fCCell Is Nothing Then
            MsgBox "No 'C' cell found before first W cell"
            Exit Sub
        End If
       
        'Transfer value
        fWCell.Offset(0, 2).Value = fCCell.Offset(0, 2).Value
       
        'Find next cell
        Set fWCell = .Find(what:="W", after:=fWCell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
    Loop Until fWCell.Address = firstAdd
End With

Application.ScreenUpdating = True

End Sub

 

[k3vsmith]

Awesome. Thank you sir!

 

[k3vsmith]

Likewise, can you provide vba code to then copy the header and all blanks to sheet2 or in my example report sheet3. Blanks as in WBS Element indicator on blanks.
I basically want to move all blanks off of my main report as a last step.

 

[Luke M]

I wrote the new macro as a separate sub, but it's called from previous. Example didn't have any blank rows, but it should still work.

Sub FindCams()
Dim fWCell As Range
Dim fCCell As Range
Dim firstAdd As String
Dim ws As Worksheet

'Which worksheet are we dealing with?
Set ws = ActiveSheet

Application.ScreenUpdating = False
'Make sure all rows are visible
ws.AutoFilterMode = False
With ws.Range("C:C")
    Set fWCell = .Find(what:="W", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
   
    If fWCell Is Nothing Then
        MsgBox "No cells found with a 'W'."
        Exit Sub
    Else
        firstAdd = fWCell.Address
    End If
   
    'Loop over W cells
   Do
        Set fCCell = .Resize(fWCell.Row).Find(what:="C", after:=fWCell, _
            LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious, MatchCase:=False)
       
        If fCCell Is Nothing Then
            MsgBox "No 'C' cell found before first W cell"
            Exit Sub
        End If
       
        'Transfer value
       fWCell.Offset(0, 2).Value = fCCell.Offset(0, 2).Value
       
        'Find next cell
       Set fWCell = .Find(what:="W", after:=fWCell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
    Loop Until fWCell.Address = firstAdd
End With
'Call other macro
Call CopyBlanks

Application.ScreenUpdating = True

End Sub

Sub CopyBlanks()
Dim wsOld As Worksheet
Dim wsNew As Worksheet
Dim rngFilter As Range

Set wsOld = ActiveSheet
Set wsNew = ThisWorkbook.Worksheets.Add
With wsOld
    Set rngFilter = .Range("A2", .Cells.SpecialCells(xlCellTypeLastCell))
    rngFilter.AutoFilter field:=4, Criteria1:="="
    rngFilter.SpecialCells(xlCellTypeVisible).Copy wsNew.Range("A1")
    rngFilter.AutoFilter
End With
   
End Sub

 

[k3vsmith]

Thanks, that copies the header over but not all the rows that have WBS Indicator as blank. Actually I should restate copy as cut or move. I want to move all blanks from the Test Report over to the new sheet.

 

[Luke M]

Change the second macro like so

Sub CopyBlanks()
Dim wsOld As Worksheet
Dim wsNew As Worksheet
Dim rngFilter As Range

Set wsOld = ActiveSheet
Set wsNew = ThisWorkbook.Worksheets.Add
With wsOld
    Set rngFilter = .Range("A2", .Cells.SpecialCells(xlCellTypeLastCell))
    rngFilter.AutoFilter field:=4, Criteria1:="="
    rngFilter.SpecialCells(xlCellTypeVisible).Copy wsNew.Range("A1")
'New code line, removes data from source
    rngFilter.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    rngFilter.AutoFilter
End With
   
End Sub

 

[k3vsmith]

This copies only the header over to new sheet. No data is moved to new sheet and the blanks on the original worksheet remain. I can keep playing around with it. Will post back when I find a solution.

 

[Luke M]

Ah, I see it now. Filter was being applied to col D, but you wanted blank in col C.

Change this:

rngFilter.AutoFilter field:=4, Criteria1:="="

to this

rngFilter.AutoFilter field:=3, Criteria1:="="

Apologies for not seeing that sooner

 

[k3vsmith]

Perfect, thank you kindly. I was recording a macro and checking code and it wasn't exactly what I wanted.
Your modification works as I wanted. Thanks again for the assistance.