Macro to copy and transpose every row and past in Cell Q1 Column

0
votes

I have village names in column A.as below mentioned format

VILLAGE
Campbelbay
Carnicobar
Champin
Chowra
Gandhinagar
Kakana
Kapanga

With this format I have around 700 sheets in workbook. I need to get the same transposed to the below mentioned format in Column(cell) Q1.

Campbelbay,Carnicobar,Champin,Chowra,Gandhinagar,Kakana,Kapanga

I have a macro code works for 8 cells and for one sheet, can somebody help me to apply this macro to all sheets with auto select row number.? i.e, Sheets1 has 30 rows, sheet2 has 50 rows and sheet n has n rows.

I do not have much of knowledge in VB.

Following is the code that works for Sheet1: Ref:

macro to copy and transpose every seventh row and past in new sheet

Public Sub TransposeData()
    Dim LastRow As Long
    Dim NextRow As Long
    Dim i As Long

    Application.ScreenUpdating = False

    With Worksheets("Sheet1")
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For i = 1 To LastRow Step 8
            .Cells(i, "A").Resize(8).Copy
            NextRow = NextRow + 1
            .Cells(NextRow, "B").PasteSpecial Paste:=xlPasteAll, transpose:=True
        Next i

        .Rows(NextRow + 1).Resize(LastRow - NextRow).Delete
        .Columns(1).Delete
    End With

    Application.ScreenUpdating = True
End Sub
2
vbaexcel
You should explain where you want the results, and whether they should be in a single cell or multiple cells - your question is contradictory. – SJR
Agree with @SJR couldn't work out what you wanted presentation wise. – Nathan_Sav

2 Answers

0
votes

You will need to loop the sheets collection worksheets and use the .end something like so

Sub test()

Dim w As Excel.Worksheet
Dim r As Excel.Range

For Each w In ThisWorkbook.Worksheets

    Set r = Range("a2", w.Range("a1").End(xlDown))
    w.Range("q1").Value = Join(Application.Transpose(r.Value), ",")

Next w

End Sub

Couldn't work out whether you wanted them in the same sheet in Q, if so you'll need to change

w.Range("q1").Value = Join(Application.Transpose(r.Value), ",")

to something like

worksheets("result").range("q1").end(xldown).offset(1,0)=

Hope this helps, not fully tested the last line.

Thanks

-1
votes

Try this

Sub test()
    Dim w As Excel.Worksheet
    Dim r As Excel.Range

    For Each w In ThisWorkbook.Worksheets
        Set r = w.Range("a2", w.Range("a1").End(xlDown))
        w.Range("q1").Value = Join(Application.Transpose(r), ",")
    Next w
End Sub