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

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