Excel VBA代码可将循环中不同范围的值复制/粘贴（转置）到不同的工作表中

Question

我要在excel中完成一项（对我而言）相当复杂的任务。 我想将一系列值（转置）复制到另一张纸上。 值的范围是1到99，并且始终按升序排列。

任务是要有一个VBA，这使我可以用所需的信息填充此工作表，并在循环中重复执行此操作，直到所有值都填满为止。为此，我想将具有近一百万行的工作表转换为约一个。 25000行左右 100列。 请查看我想做什么的屏幕截图。

第一张图片是数据表（第1页）。 我想将C列中的值范围复制到工作表2中的适当位置。每次名称更改（值再次从低端开始）时，工作表2中都会开始新的一行。

也许我总是知道范围有多长，这会有所帮助，因为我知道此名称出现在多少个样本中（1-99），所以我知道范围将是例如C2：C6（因为此名称是5个样本） ，然后是C7：11（又是5个样本）等。

也许您可以帮我吗？ 我不能一个人做。

图片1

图片2：

Answer 1

我曾经有几乎完全相同的问题（我的问题是，我需要将值连接到单个文本字符串中，而不是单个单元格中！）

在excel中做起来并不像我想的那么容易。 我的解决方案如下：

Sub TransP()

Dim LastRow As Integer
Dim LastCol As Integer

LastRow = Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
LastCol = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column

'Clear cells from sheet2

Worksheets("Sheet2").Select

Cells.Select
Selection.ClearContents

'Copy full range from sheet 1

Worksheets("Sheet1").Select

Worksheets("Sheet1").Range(Cells(1, 1), Cells(LastRow, LastCol)).Select
Selection.Copy

'Paste into sheet 2

Worksheets("Sheet2").Select
ActiveSheet.Paste

LastRow = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row

'Iteration to transpose and collate data together

For i = 2 To LastRow

    If Cells(i, 2).Value = Cells(i + 1, 2).Value Then

        LastCol = Worksheets("Sheet2").Cells(i, Columns.Count).End(xlToLeft).Column

        Cells(i, LastCol + 1).Value = Cells(i + 1, 3).Value

        Rows(i + 1 & ":" & i + 1).Select

        Selection.Delete Shift:=xlUp

        i = i - 1

    End If

'Exit sub when it reaches the end (blank cell)

    If Cells(i, 2).Value = "" Or Cells(i + 1, 2).Value = "" Then

        Exit Sub

    End If

Next

End Sub