Results 1 to 6 of 6

Thread: Copy Rows - Paste and remove blanks

  1. #1
    Acolyte tigerdel's Avatar
    Join Date
    Aug 2012
    Location
    Cambridgeshire
    Posts
    29
    Articles
    0

    Copy Rows - Paste and remove blanks



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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

    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
    Attached Files Attached Files

  2. #2
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,225
    Articles
    57
    Blog Entries
    14
    Excel Version
    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.
    Ken Puls, FCPA, FCMA, MS MVP (Excel)

    Learn to Master Your Data at the Power Query Academy (the world's most comprehensive online Power Query training) or with my book M is for Data Monkey!

    Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
    Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter

    If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.

  3. #3
    Acolyte tigerdel's Avatar
    Join Date
    Aug 2012
    Location
    Cambridgeshire
    Posts
    29
    Articles
    0
    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???

  4. #4
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,225
    Articles
    57
    Blog Entries
    14
    Excel Version
    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
    Ken Puls, FCPA, FCMA, MS MVP (Excel)

    Learn to Master Your Data at the Power Query Academy (the world's most comprehensive online Power Query training) or with my book M is for Data Monkey!

    Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
    Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter

    If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.

  5. #5
    Acolyte tigerdel's Avatar
    Join Date
    Aug 2012
    Location
    Cambridgeshire
    Posts
    29
    Articles
    0
    Thank you so much for your help

  6. #6
    Acolyte tigerdel's Avatar
    Join Date
    Aug 2012
    Location
    Cambridgeshire
    Posts
    29
    Articles
    0

    [SOLVED] Copy Rows - Paste and remove blanks

    Thanks for all your help - working now

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •