excel vba 1

[Bwaggoner]

I have a workbook with data in it that I want to copy and put in another wookbook. The data looks like this.

D11/22'2005
CX
T-7.80
PEl Azabache
LDining Out
(blank cell)
D11/22'2005
CX
T-9.50
PAce Hardware
LHousehold
(blank cell)

What I want is a macro to copy that data until it finds a blank cell and paste/transpose that data in another workbook and then get the next set of data until an other blank cell.

It should look like this when done.

D11/22'2005 CX T-7.80 PEl Azabache LDining Out
D11/22'2005 CX T-9.50 PAce Hardware LHousehold

 

[ck1999]

if they are always groups of 5 then
assuming data in column a

sub helping()
dim jarray(100,5) ' Will do 100 sets
dim keepgoing as boolean
keepgoing=true
' Replace the 1 with whatever line the data starts in
counter2=1
for counter =1 to 1000 step 6
jarray(counter2,1) = range("a" & counter).value
jarray(counter2,2) = range("a" & counter+1).value
jarray(counter2,3) = range("a" & counter+2).value
jarray(counter2,4) = range("a" & counter+3).value
jarray(counter2,5) = range("a" & counter+4).value
counter2=counter2+1
next counter
'replace filename below with the filename you want to use and make sure it is open
workbook("book1.xls").activate
for counter = 1 to counter2
range("a"&counter).value = jarray(counter,1)
range("b"&counter).value = jarray(counter,2)
range("c"&counter).value = jarray(counter,3)
range("d"&counter).value = jarray(counter,4)
range("e"&counter).value = jarray(counter,5)
next counter

end sub


try this code

 

[cummings54]

As always there is more than one way to skin a rabbit. Here's another example. I'm assuming you first select your data and that Sheet2 is the code name for the worksheet that will hold the reorganized data.

Sub test()
  Set a = Selection
  irow = 1
  jcol = 0
  For i = 1 To UBound(a.Value, 1)
    strIn = a(i, 1)
    If strIn = "" Then
      jcol = 0: irow = irow + 1
    Else
      jcol = jcol + 1
      Sheet2.Cells(irow, jcol) = strIn
    End If
  Next i
End Sub

 

[Bwaggoner]

Thanks for the replies. I found something that worked for me.

Option Explicit

Sub CopyAndTranspose()
Dim CopyRange As Range
Dim cl As Range

Set CopyRange = Range("A8", Range("A65536").End(xlUp).Offset(1, 0))

For Each cl In CopyRange
If IsEmpty(cl) Then
cl.Offset(-1, 0). CurrentRegion.Resize(, 1).Copy
Sheets("sheet2").Range("a65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
'Sheet2.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
End If
Next cl

End Sub