copy the data to all the columns

[Ranjith Kurian]

Hi,

I have 5000 names in a excel sheet and after every name there is blank row,
i need macro to copy the DEPT and CCentre data to all the names example as
shown below

Name DEPT CCENTRE
A1 A P
A1 S U
A1 D Y
A1 R K

B2 A P
B2 S U
B2 D Y
B2 R K
B2

 

[Abhi]

Hi All,

Please Tell Me [ How to open Hidden excel Sheet But Only I Follow the
Hyperlink ]
& Please Send me Screen Shot ok

Thanks
Abhijeet

 

[joel]

Try something like this. the code put the results in the DESTSHT whic
is sheet 2.




VBA Code:
--------------------


Sub CopyNames()

Set Sourcesht = Sheets("Sheet1")
Set DestSht = Sheets("Sheet2")

With DestSht
.Range("A1") = "Name"
.Range("B1") = "DEPT"
.Range("C1") = "CCENTRE"
End With

NewRow = 2
With Sourcesht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
Name = .Range("A" & RowCount)
If Name <> "" Then
With DestSht
.Range("A" & NewRow) = Name
.Range("B" & NewRow) = "A"
.Range("C" & NewRow) = "P"
NewRow = NewRow + 1
.Range("A" & NewRow) = Name
.Range("B" & NewRow) = "S"
.Range("C" & NewRow) = "U"
NewRow = NewRow + 1
.Range("A" & NewRow) = Name
.Range("B" & NewRow) = "D"
.Range("C" & NewRow) = "Y"
NewRow = NewRow + 1
.Range("A" & NewRow) = Name
.Range("B" & NewRow) = "R"
.Range("C" & NewRow) = "K"
NewRow = NewRow + 1
End With
End If
Next RowCount
End With

End Sub


--------------------

 

[Nick]

Hi Ranjith-


If I understand your issue correctly, there are two options for doing this:


(1)Highlight the cells you want to copy including a row of empty cells and
drag this until the end of your document.

(2)If all the data you want to copy is found in “B2:C5†and there are four
names between each space the following code should work:
Option Explicit
Dim X As Long


Sub RepeatCopy()

Range("B2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

X = 0

Do

Range("b7").Offset(5 * X, 0).Select
ActiveSheet.Paste
Selection.End(xlDown).Select
Selection.End(xlToLeft).Select
' Selection.End(xlDown).Select
X = X + 1
Loop Until IsEmpty(ActiveCell.Offset(2, 0))

End Sub