Multiple Colums & Rows Copy & Paste - Transpose - Looped

[hcabs99]

Hi All

I have a table with multiple Columns & rows (number of columns & rows will vary between Sheets) , i need excel to take each row individually , copy all the populated columns , paste (transpose) into next free cell on a new sheet, then move to the next (populated ) row and repeat. Number of rows will change.

I have a little experience of looping functionality , but i would appreciate some help here.

Let me know if i need to provide any more information

Cheers

Phil

 

[bensmith1987]

A few questions...

1) On each sheet are you expecting blank rows between other populated rows? Or blank values within rows?
2) Do you want the loop to be row by row, or sheet by sheet, or both?

Thanks
Ben

 

[hcabs99]

A few questions...

1) On each sheet are you expecting blank rows between other populated rows? Or blank values within rows?
2) Do you want the loop to be row by row, or sheet by sheet, or both?

Thanks
Ben

1) No, I end up with one column with the transposed data on one sheet
2) - Row by row please.

Example

Row 1 - 12. 34, 25. 25 . 36
Row 2 -14 . 55, 67, 23. 12
Row 3 - 34, 24, 12


End Results

12
34
25
25
36
14
55
67

Etc etc

Does that help explain?

 

[bensmith1987]

1) No, I end up with one column with the transposed data on one sheet
2) - Row by row please.

Example

Row 1 - 12. 34, 25. 25 . 36
Row 2 -14 . 55, 67, 23. 12
Row 3 - 34, 24, 12


End Results

12
34
25
25
36
14
55
67

Etc etc

Does that help explain?

All good. Try the code below.
It's lengthy and maybe someone could do it in a simpler way - but it works

Sub Test()

Dim CWN As String
CWN = ActiveSheet.Name

Dim CW As Worksheet
Set CW = Worksheets(CWN)

Dim wsname As String
wsname = "NewSheet" 'Set new sheet name here!
Dim ws As Worksheet
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = wsname

Dim r As Range
Dim ChkRng As Range

CW.Activate
Range("A1").Select

If Range("A1") = "" Or Range("A1") = Null Or Range("A1") = Empty Or Range("A1") = Blank Then
    ' Do Nothing
    MsgBox "No rows to copy!"
ElseIf Range("A2") = "" Or Range("A2") = Null Or Range("A2") = Empty Or Range("A2") = Blank Then
    Range(ActiveCell, ActiveCell.End(xlToRight)).Select
    Selection.Copy
    Worksheets(wsname).Activate
    Range("A1").PasteSpecial xlPasteAll
Else
    Set ChkRng = Range(ActiveCell, ActiveCell.End(xlDown))
    For Each r In ChkRng
        Range(r, r.End(xlToRight)).Copy
        Worksheets(wsname).Activate
        If Range("A1") = "" Or Range("A1") = Null Or Range("A1") = Empty Or Range("A1") = Blank Then
            Range("A1").PasteSpecial Transpose:=True
        ElseIf Range("A2") = "" Or Range("A2") = Null Or Range("A2") = Empty Or Range("A2") = Blank Then
            Range("A2").PasteSpecial Transpose:=True
        Else
            Range("A1").End(xlDown).Offset(1, 0).PasteSpecial Transpose:=True
        End If
    Next r
End If

End Sub

It copied the below in Sheet1:

A1	B1	C1	D1
A2	B2	C2
A3	B3	C3	D3
A4	B4
A5	B5	C5	D5
A6

<colgroup><col style="width:48pt" width="64" span="4"> </colgroup><tbody>
</tbody>

To the below in NewSheet:

A1

B1

C1

D1

A2

B2

C2

A3

B3

C3

D3

A4

B4

A5

B5

C5

D5

A6

<colgroup><col style="width:48pt" width="64"> </colgroup><tbody>
</tbody>

 

[hcabs99]

Excellent, that works really well , many many thanks! Is it possible to put one more tweak in? For the rows, there is a an indicator for each set of records.. Is it possible to also include this in a separate column next to the transposed data? So the same indicator would appear multiple times .

Cheers
Phil

 

[Fluff]

Another option

Sub hcabs99()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, rr As Long
   
   Ary = Sheets("Data").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 2)
   For r = 1 To UBound(Ary)
      For c = 1 To UBound(Ary, 2)
         If Ary(r, c) <> "" Then
            rr = rr + 1
            Nary(rr, 1) = Ary(r, c)
         End If
      Next c
   Next r
   Sheets("Sheet2").Range("A1").Resize(rr, 2).Value2 = Nary
End Sub

Where is the row indicator located?

 

[hcabs99]

Row indicator is alongside each group of columns.. To keep it simple.. Row Indicator A1 , B1, C1 Etc , Columns with all the values A2, A3, A4, A5, B2, B3, B4, C2, C3, C4

Cheers
Phil

 

[Fluff]

wrong!

 

[Fluff]

Try

Sub hcabs99()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, rr As Long
   
   Ary = Sheets("Data").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 2)
   For r = 2 To UBound(Ary)
      For c = 1 To UBound(Ary, 2)
         If Ary(r, c) <> "" Then
            rr = rr + 1
            Nary(rr, 1) = Ary(1, c)
            Nary(rr, 2) = Ary(r, c)
         End If
      Next c
   Next r
   Sheets("sheet2").Range("A1").Resize(rr, 2).Value2 = Nary
End Sub

 

[hcabs99]

Try

Sub hcabs99()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, rr As Long
   
   Ary = Sheets("Data").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 2)
   For r = 2 To UBound(Ary)
      For c = 1 To UBound(Ary, 2)
         If Ary(r, c) <> "" Then
            rr = rr + 1
            Nary(rr, 1) = Ary(1, c)
            Nary(rr, 2) = Ary(r, c)
         End If
      Next c
   Next r
   Sheets("sheet2").Range("A1").Resize(rr, 2).Value2 = Nary
End Sub

I must confess, I don't fully understand what this message is doing to enable me to adapt to fit my sheet. So perhaps I can ask you to adapt as follows please:

Source Sheet "Source"
Destination "Conversion"

First row indictor = B38, then the actual values starts J38 and goes to Aj38
Second row indicator = B39 , first value starts J39 and goes to AH39

So I start with

Indicator1 .... Value 1, Value 2, Value 3
Indicator2 ..... Value A, Value, B, Value, C


Result

Indicator1,Value1
Indicator1,Value2
Indicator1,Value3
Indicator2,ValueA
Indicator2,ValueB
Indicator2,ValueC

Is this possible please?