Copy Rows - Paste and remove blanks

tigerdel

New member
Joined
Aug 23, 2012
Messages
40
Reaction score
0
Points
0
Location
Cambridgeshire
Excel Version(s)
Office 365
[h=2]What I need is a macro that will look for the name Sheet 4 – cell c6 from the names in Sheet 3 and when it finds the name, copies the row, pastes as text and then removes the blank cells and the date above the blank cell so that it shows only the dates with H in them and the date above it[/h]
I have attached the book I am using to try out this

This is driving me nuts so any help here would be greatly appreciated​
 

Attachments

  • Test Book.xlsx
    105.6 KB · Views: 27

Ken Puls

Administrator
Staff member
Joined
Mar 13, 2011
Messages
2,519
Reaction score
4
Points
38
Location
Nanaimo, BC, Canada
Website
www.excelguru.ca
Excel Version(s)
Excel Office 365 Insider
This will be slow, but should work for you:

Code:
Sub Macro1()    
    Dim wsSource As Worksheet
    Dim wstarget As Worksheet
    Dim cl As Range
    Dim lCol As Long
    Dim lcols As Long
    Dim sCriteria As String
    Dim sEmployee As String
    
    'Set variables here for easier coding
    Set wsSource = Worksheets("Sheet3")
    Set wstarget = Worksheets("Sheet4")
    sCriteria = "H"
    sEmployee = wstarget.Range("C6").Value


    'Turn off screen updates for speed
    Application.ScreenUpdating = False


    'Restore the first row on the Target worksheet
    With wsSource
        .Range("A1:" & .Range("C1").End(xlToRight).Address).Copy
        wstarget.Range("A1").PasteSpecial Paste:=xlPasteAll
    End With
    
    'Copy the desired row
    With wsSource
        For Each cl In .Range("B3:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
            If cl.Value = sEmployee Then
                wsSource.Rows(cl.Row).Copy
                wstarget.Rows("2").PasteSpecial Paste:=xlValues
                wstarget.Rows("2").PasteSpecial Paste:=xlFormats
                Exit For
            End If
        Next cl
    End With
    
    'Kill all non "H" columns
    With wstarget
        lcols = .Range("C1").End(xlToRight).Column
        For lCol = lcols To 4 Step -1
            If Not .Cells(2, lCol).Value = sCriteria Then .Columns(lCol).Delete
            Application.StatusBar = "Revieiwing dates... " & Round((1 - (lCol / lcols)) * 100, 0) & "% complete..."
        Next lCol
    End With
    
    'Turn off statusbar
    Application.StatusBar = False
End Sub

If you have thousands of employees, it may be an idea to recode the initial loop using a FIND method, as that would be faster. With only 20 though, it wouldn't make a ton of difference.
 

tigerdel

New member
Joined
Aug 23, 2012
Messages
40
Reaction score
0
Points
0
Location
Cambridgeshire
Excel Version(s)
Office 365
Thank you so much for your reply it worked a treat

I have just noted that I not only need the H but also the LT which I omitted from my previous sheets

Can it look up 2 criteria???
 

Ken Puls

Administrator
Staff member
Joined
Mar 13, 2011
Messages
2,519
Reaction score
4
Points
38
Location
Nanaimo, BC, Canada
Website
www.excelguru.ca
Excel Version(s)
Excel Office 365 Insider
Didn't test it, but try this:

Code:
Sub Macro1()    Dim wsSource As Worksheet
    Dim wstarget As Worksheet
    Dim cl As Range
    Dim lCol As Long
    Dim lcols As Long
    Dim sCriteria As String
    Dim sEmployee As String
    
    'Set variables here for easier coding
    Set wsSource = Worksheets("Sheet3")
    Set wstarget = Worksheets("Sheet4")
    sCriteria1 = "H"
    scriteria2 = "LT"
    sEmployee = wstarget.Range("C6").Value




    'Turn off screen updates for speed
    Application.ScreenUpdating = False




    'Restore the first row on the Target worksheet
    With wsSource
        .Range("A1:" & .Range("C1").End(xlToRight).Address).Copy
        wstarget.Range("A1").PasteSpecial Paste:=xlPasteAll
    End With
    
    'Copy the desired row
    With wsSource
        For Each cl In .Range("B3:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
            If cl.Value = sEmployee Then
                wsSource.Rows(cl.Row).Copy
                wstarget.Rows("2").PasteSpecial Paste:=xlValues
                wstarget.Rows("2").PasteSpecial Paste:=xlFormats
                Exit For
            End If
        Next cl
    End With
    
    'Kill all non "H" columns
    With wstarget
        lcols = .Range("C1").End(xlToRight).Column
        For lCol = lcols To 4 Step -1
            Select Case .Cells(2, lCol).Value
                Case Is = sCriteria1, scriteria2
                    'Matches what we want, so leave it alone!
                Case Else
                    .Columns(lCol).Delete
            End Select
            Application.StatusBar = "Revieiwing dates... " & Round((1 - (lCol / lcols)) * 100, 0) & "% complete..."
        Next lCol
    End With
    
    'Turn off statusbar
    Application.StatusBar = False
End Sub
 

tigerdel

New member
Joined
Aug 23, 2012
Messages
40
Reaction score
0
Points
0
Location
Cambridgeshire
Excel Version(s)
Office 365
[SOLVED] Copy Rows - Paste and remove blanks

Thanks for all your help - working now
 
Top