复制和转置每一行并粘贴到单元格 A1 列中的宏答案

【问题标题】：Macro to copy and transpose every row and past in Cell Q1 Column复制和转置每一行并粘贴到单元格 A1 列中的宏
【发布时间】：2017-10-02 08:52:43
【问题描述】：

我在 A 列中有村庄名称。如下所述的格式

VILLAGE
Campbelbay
Carnicobar
Champin
Chowra
Gandhinagar
Kakana
Kapanga

使用这种格式，我的工作簿中有大约 700 张工作表。我需要在 Column(cell) Q1 中将相同的转换为下面提到的格式。

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

我有一个适用于 8 个单元格和一张工作表的宏代码，有人可以帮我将此宏应用于所有具有自动选择行号的工作表吗？即 Sheets1 有 30 行，sheet2 有 50 行，而 sheet n 有 n 行。

我对 VB 了解不多。

以下是适用于 Sheet1 的代码：参考：

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

【问题讨论】：

你应该解释你想要的结果，以及它们应该在单个单元格还是多个单元格中 - 你的问题是矛盾的。
同意@SJR 无法解决您想要的演示文稿。

标签： vba excel

【解决方案1】：

您将需要循环工作表集合 worksheets 并使用 .end 类似的东西

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

无法确定您是否希望它们在 Q 中的同一张表中，如果是，则需要更改

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

类似

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

希望这有帮助，最后一行没有完全测试。

谢谢

【讨论】：

感谢 Nathan，在运行宏后显示错误“范围对象 _global 失败的 excel 宏”（）并仅在工作表 1 中运行。更改显示编译错误的行后。
抱歉，我看不到你的屏幕。
您能否在您的系统中运行您的代码，sheet2 数据是 VILLAGE Little Nicobar Mildera Mus Nancowrie Nehrugram Pilomilo Island Sawai Shabnamnagar Teressa Trinket Aerial Bay Bakultala Betapur
不，我不能，我有自己的工作要做，我使用与您类似的数据对其进行了测试，并得到了预期的结果。

【解决方案2】：

试试这个

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

【讨论】：

感谢 Imran，非常感谢...您拯救了我的一天。完美的解决方案。
@Ram 这和你说的我的解决方案一样，但行不通。
@Nathan_Sav 感谢您的帮助，但您的代码在“w.Range("q1").Value = Join(Application.Transpose(r.Value), ",") 行给了我错误" 同一行在 IMran 的代码中有所不同，即 "w.Range("q1").Value = Join(Application.Transpose(r), ",")" 但运行成功。我是外行。
@Imran Malek，Imran 能否编辑代码以自动填充 q1（在 Q 列中）结果，直到 A 列中相应单元格的末尾。