Excel VBA代码可将大量数据从多个范围移动到列


Excel VBA code that moves large amounts of data from multiple ranges to columns

我正在研究鸟类迁移模式，但在尝试找出在excel中移动数据的最佳和最简便方法时遇到了麻烦。我擅长擅长于Excel，但是我在宏和VBA编码方面很糟糕，所以如果我对编码的想法似乎完全错误，并且向专家咨询没有任何错，我要提前道歉。到目前为止，我已经使用数据透视表根据物种数量，位置和日期来缩小鸟类的范围。

pivot table

之后，我将数据从每个物种的日期移开，并将它们从一个范围堆叠到单个列中。

single column

我确实找到了一个有效的vba代码(即使输出实际上是将数据从左向右横向移动，也仍然是相同的"移动B4：P4，B5：P5，B6：P6等。")，但这一次只是一个范围：

1
2
3
4
5
6
7
8
9
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次单因素分析。如果有人可以提供帮助，那将是惊人的，并且对科学非常有帮助。

我的想法/希望和梦想：

如果可以在同一VBA代码模块中重复该代码，并更改每个种类的范围和输出位置的值。这3个地点的格式和位置均相同(加上减去两个额外的日期)，或者可以将地点设置为另一张工作表。像这样

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
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

看起来像这样：

single column

或更优选的是：

more preferably

再次感谢您的帮助和贡献。 ：D

相关讨论

乍一看似乎有点复杂。 我做了一些假设，因此，如果这些假设站不住脚，可能需要进行一些调整：

  • 起始工作簿每个位置只有一张工作表，即工作表数等于位置数
  • 数据从每张纸上的B4开始(以及A3，A14等中的物种名称)
  • 每个位置表具有相同数量的物种

对于实际代码，请使用更有意义的过程和变量名。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
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

相关讨论