juville
09-02-2018, 11:45 PM
Hi all, i have this code below to copy my data (below the header) to another worksheet with the same header.
The macro will automatically find those with the same header name and populates the data below.
however, it seems like, whenever there's a blank in that column, it stops at the cell before the blank.
Eg. Column E, it stops at row 23 as there's a blank cell at row 24. However there is still data on cell E25 onwards.
How do i resolve this?
Thank you
Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Dim dest As Range
Dim lDestRow As Long
Dim i As Integer
Dim lastRow As Long
' MsgBox Range("D65536").End(xlUp).Select
Sheets("Base Sheet").Select
i = 0
Set Rng = Range([D3], [D3].End(xlToRight))
For Each c In Rng
Set sCell = Sheets("Roster").Range("3:1").Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole)
rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
'c.End(xlDown).Offset(1, 0).Resize(rSize, 1) = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Set dest = c.End(xlDown).Offset(1, 0)
If i = 0 Then
lDestRow = dest.Row
End If
If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If
Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
dest.Select
ActiveSheet.Paste
Else
'c.Offset(1, 0).Resize(rSize, 1).Value = Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Set dest = c.Offset(1, 0)
If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If
dest.Select
ActiveSheet.Paste
End If
i = i + 1
Next
End Sub
The macro will automatically find those with the same header name and populates the data below.
however, it seems like, whenever there's a blank in that column, it stops at the cell before the blank.
Eg. Column E, it stops at row 23 as there's a blank cell at row 24. However there is still data on cell E25 onwards.
How do i resolve this?
Thank you
Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Dim dest As Range
Dim lDestRow As Long
Dim i As Integer
Dim lastRow As Long
' MsgBox Range("D65536").End(xlUp).Select
Sheets("Base Sheet").Select
i = 0
Set Rng = Range([D3], [D3].End(xlToRight))
For Each c In Rng
Set sCell = Sheets("Roster").Range("3:1").Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole)
rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
'c.End(xlDown).Offset(1, 0).Resize(rSize, 1) = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Set dest = c.End(xlDown).Offset(1, 0)
If i = 0 Then
lDestRow = dest.Row
End If
If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If
Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
dest.Select
ActiveSheet.Paste
Else
'c.Offset(1, 0).Resize(rSize, 1).Value = Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Set dest = c.Offset(1, 0)
If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If
dest.Select
ActiveSheet.Paste
End If
i = i + 1
Next
End Sub