copy the data to all the columns
 

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

copy the data to all the columns
 

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

copy the data to all the columns
 

Try something like this. the code put the results in the DESTSHT which
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


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


--
joel
------------------------------------------------------------------------
joel's Profile: http://www.thecodecage.com/forumz/member.php?u=229
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=200007

http://www.thecodecage.com/forumz

copy the data to all the columns
 

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


"Ranjith Kurian" wrote:

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