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 a Должно быть, я думаю. Мое решение ниже :)

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