Copy and Pasting Cells with VBA..help

[nickadeemus2002]

I have a directory of business address to make into a database. The
current format is like this:

A B C
R1 Co.Name
R2 Add1
R3 CSZ
R4 Phone
R5 Blank
R6 Blank
R7 Co.Name (2)
R8 Add1 (2)
R9 CSZ(2)
R10 Phone(2)
R11 Blank
R12 Blank
and this repeats down through the spreadsheet.

I need to keep the Co.Names in column A, copy/paste Add1 in B, CSZ in C
and so on. Then all the data and blank cells in A must be deleted,
except the company name of course.

I was thinking of trying to loop this. Is this the best method? What
would the code be? Any suggestions?

 

[kkknie]

Assuming each entry has exactly 12 rows, the code would be:

Code
-------------------
Sub test()

Dim i As Long

For i = 1 To 100
Cells(i, 1).Value = Cells((i - 1) * 12 + 1, 1).Value
Cells(i, 2).Value = Cells((i - 1) * 12 + 2, 1).Value
Cells(i, 3).Value = Cells((i - 1) * 12 + 3, 1).Value
Cells(i, 4).Value = Cells((i - 1) * 12 + 4, 1).Value
Cells(i, 5).Value = Cells((i - 1) * 12 + 5, 1).Value
Cells(i, 6).Value = Cells((i - 1) * 12 + 6, 1).Value
Cells(i, 7).Value = Cells((i - 1) * 12 + 7, 1).Value
Cells(i, 8).Value = Cells((i - 1) * 12 + 8, 1).Value
Cells(i, 9).Value = Cells((i - 1) * 12 + 9, 1).Value
Cells(i, 10).Value = Cells((i - 1) * 12 + 10, 1).Value
Cells(i, 11).Value = Cells((i - 1) * 12 + 11, 1).Value
Cells(i, 12).Value = Cells((i - 1) * 12 + 12, 1).Value
Next

End Su

 

[Dave Peterson]

How about a worksheet formula (and some minor editting)?

put this formula in B1:
=INDEX($A:$A,MOD(COLUMN()-2,12)+1+(ROW()-1)*12)
And drag through M1.
Then select B1:M1 and drag down.

Keep going until you get 0's returned (1/12 the way through your data).

Then select columns B:M and do
edit|copy
Edit|paste special values
then
Edit|replace
replace 0 with (leave blank)
but check "match entire cells contents" under the options button.

Finally, Delete column A.

======
And another way in code is to loop through in steps of 12 rows at a time. Just
paste special|transpose.

Option Explicit
Sub testme()

Application.ScreenUpdating = False

Dim wks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long

Set wks = ActiveSheet
With wks
FirstRow = 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = FirstRow To LastRow Step 12
.Cells(iRow, "A").Resize(12).Copy
.Cells(iRow, "B").PasteSpecial Transpose:=True
Next iRow

On Error Resume Next
.Range("b:b").Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
.Range("a:a").Delete
End With

Application.ScreenUpdating = True

End Sub