Код Excel VBA, который перемещает большие объемы данных из нескольких диапазонов в столбцы

Question

Я изучаю модели миграции птиц, и у меня возникают проблемы, когда я пытаюсь найти лучший и самый простой способ перемещения данных в Excel. Я неплохо справляюсь с Excel, но я ужасно разбираюсь в макросах и VBA-кодировании, поэтому заранее прошу прощения, если мои мысли о кодировании выглядят совершенно неверно, и что нет ничего плохого в том, чтобы обратиться за советом к эксперту. До сих пор я использовал сводную таблицу для сужения птиц по количеству видов, местоположению и датам.

После этого я переместил данные из дат по видам и складывать их из диапазона в один столбец.

Я нашел код VBA, который работает (хотя вывод фактически перемещает данные вбок слева направо, это то же самое, что «перемещает B4: P4, B5: P5, B6: P6 и т. д. c ..»), но это только один диапазон за раз :

Sub main()
Dim i As Long
Dim cell As Range

For Each cell In Range("B4:P13")
    Range("S4").Offset(i).Value = cell.Value
    i = i + 1
Next cell
End Sub

Моя проблема в том, что существует 56 видов и 3 локации. Таким образом, мне нужно переместить данные 168 раз, что смешно. После того, как я их организовал, я провел 56-факторный анализ 56 раз для каждого вида в каждом из трех мест. Если кто-то может помочь, это было бы удивительно и очень полезно для науки.

Мои идеи / надежды и мечты:

Если я смогу повторить код в том же модуле кода VBA и изменить значения диапазонов и выходных местоположений для каждого вида. Все 3 местоположения имеют одинаковый общий формат и расположение диапазонов (плюс минус две дополнительные даты), или, если я могу установить местоположение на другой лист. Вот так…

Sub main()
Dim i As Long
Dim cell As Range

For Each cell In Range("B4:P13")
    Range("S4").Offset(i).Value = cell.Value
    i = i + 1
For Each cell In Range("B15:P24")
    Range("U4").Offset(i).Value = cell.Value
    i = i + 1
For Each cell In Range("B26:P35")
    Range("W4").Offset(i).Value = cell.Value
    i = i + 1
For Each cell In Range("B37:P46")
    Range("Y4").Offset(i).Value = cell.Value
    i = i + 1
etc…
Next cell
End Sub

Чтобы выглядеть примерно так:

Или более предпочтительно это:

Еще раз спасибо за помощь и вклад. : D

Answer 1

Немного сложнее, чем казалось на первый взгляд. Я сделал несколько предположений, поэтому может потребоваться некоторая настройка, если они ненадежны:

• исходная рабочая книга имеет только один лист для каждого местоположения, то есть количество листов равно количеству местоположений
• данные начинаются в B4 на каждом листе (и названия видов в A3, A14 и c)
• каждый лист местоположения имеет одинаковое количество видов

Использовать более значимые имена процедур и переменных для вашего фактического кода.

Sub x()

Dim nSpec As Long, nLoc As Long, i As Long, vSpec(), j As Long, k As Long, wsOut As Worksheet, r As Range

nLoc = Worksheets.Count 'number of locations
Set r = Worksheets(1).Range("A3")
Do Until IsEmpty(r)
    i = i + 1
    ReDim Preserve vSpec(1 To i)
    vSpec(i) = r.Value
    Set r = r.Offset(11)
Loop
nSpec = UBound(vSpec) 'number of species

Set wsOut = Worksheets.Add(after:=Worksheets(Worksheets.Count)) 'add results sheet
wsOut.Name = "Results"

For i = 1 To nLoc 'headings for results sheet
    With Worksheets(i) 'for each location
        For j = 1 To nSpec 'for each species
            wsOut.Cells(1, (j - 1) * (nLoc + 1) + 1).Value = vSpec(j) 'species heading
            wsOut.Cells(2, (j - 1) * (nLoc + 1) + i).Value = .Name 'location heading
            Set r = .Range("B4").Offset((j - 1) * 11).Resize(10) 'assumes B4 is top left cell of data
            Do Until IsEmpty(r(1))
                wsOut.Cells(Rows.Count, (j - 1) * (nLoc + 1) + i).End(xlUp)(2).Resize(10).Value = r.Value 'transfer data
                k = k + 1 'move to next column
                Set r = .Range("B4").Offset((j - 1) * 11, k).Resize(10)
            Loop
            k = 0
        Next j
    End With
Next i

End Sub