PDA

View Full Version : Copy Rows - Paste and remove blanks



tigerdel
2012-08-23, 03:02 PM
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

Ken Puls
2012-08-23, 05:34 PM
This will be slow, but should work for you:


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
2012-08-23, 11:59 PM
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
2012-08-24, 05:49 PM
Didn't test it, but try this:


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
2012-08-25, 12:15 PM
Thank you so much for your help

tigerdel
2012-08-25, 01:00 PM
Thanks for all your help - working now