如何从列中的每个值复制到特定单元格？

Question

我正在尝试将这些值复制并粘贴到我们的软件理解的格式中。数字列的顺序不会改变，但位置每次都会改变。例如，它可以从A1的所有位置开始：15现在在A2上，但下次可能在A56上。

数字

文件示例：

我是vba的新手，这是我到目前为止所写的内容，但这根本没有效率。

因为列永远不会改变，只有行。我使用find找到值并向下移动一个单元格然后将其复制并粘贴到AU列上的格式中。格式如下所示：

我能想到的唯一方法就是尝试这个。

    Cells.Find(What:="ex1", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(1, 0).Select
    Selection.Copy
    Range("AU1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

我希望这可以使用循环或更有效的方式来复制这些值。最终结果需要看起来像格式。

Answer 1

使用arrays这是一种非常快速的方法，可以使处理速度更快

Option Explicit
Public Sub demo()
    Dim InArr As Variant, OutArr As Variant, headers As Variant
    Dim i As Long, j As Long, OutArrCounter As Long

    ' Update with your sheet reference
    With ActiveSheet
        headers = Application.Transpose(Application.Transpose(.Range(.Cells(1, 1), .Cells(1, 9)).Value2))
        InArr = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column)).Value2

        ReDim OutArr(1 To 4, 1 To UBound(InArr, 1) * (UBound(InArr, 2)))
        For i = LBound(InArr, 1) To UBound(InArr, 1)
            For j = LBound(headers) + 1 To UBound(headers)
                OutArrCounter = OutArrCounter + 1

                OutArr(1, OutArrCounter) = 1
                OutArr(2, OutArrCounter) = InArr(i, 1)
                OutArr(3, OutArrCounter) = headers(j)
                OutArr(4, OutArrCounter) = IIf(InArr(i, j) = vbNullString Or Trim(InArr(i, j)) = "-", 0, InArr(i, j))
            Next j
        Next i

        ReDim Preserve OutArr(1 To 4, 1 To OutArrCounter)
        ' Update with your destination
        .Cells(1, 44).Resize(UBound(OutArr, 2), UBound(OutArr, 1)).Value2 = Application.Transpose(OutArr)
    End With
End Sub

Answer 2

试试这个。我没有完成列AR，因为不确定它是否一直是1。此外，有待澄清以上有关破折号的评论，可能需要进行一些调整。

Sub x()

Dim r As Long, c As Long

c = Range("A1").CurrentRegion.Columns.Count

Application.ScreenUpdating = False

For r = 2 To Range("A" & Rows.Count).End(xlUp).Row
    Cells(r, "A").Copy
    Range("AS" & Rows.Count).End(xlUp)(2).Resize(c - 1).PasteSpecial Transpose:=True
    Cells(1, 2).Resize(, c - 1).Copy
    Range("AT" & Rows.Count).End(xlUp)(2).Resize(c - 1).PasteSpecial Transpose:=True
    Cells(r, 2).Resize(, c - 1).Copy
    Range("AU" & Rows.Count).End(xlUp)(2).Resize(c - 1).PasteSpecial Transpose:=True
Next r

Application.ScreenUpdating = True

End Sub