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

【问题标题】：How do I copy from each value from a column to specific cell?如何从列中的每个值复制到特定单元格？
【发布时间】：2019-04-30 09:53:42
【问题描述】：

我正在尝试将这些值复制并粘贴到我们的软件可以理解的格式中。数字列的顺序不会改变，但位置每次都会改变。它可能在 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

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

【问题讨论】：

你到底想做什么？我不明白。
@SJR 我将编辑问题以更清晰
好吧我明白了，你基本上是在做一系列的转置。
@SJR 理论上归结为是的
破折号的格式是零还是实际的破折号？

标签： excel vba copy-paste

【解决方案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

【讨论】：

是的，由于速度，我会选择这个而不是我自己的。
我不明白如何让它工作。当我运行它时，我得到（粗略翻译）错误 13 Types don't match on this line "For j = LBound(headers) + 1 To UBound(headers)"
我怀疑它可能将 headers 变量设置为高于上面的值 - 我已将其更新为仅使用前 9 个单元格，而不是动态设置它

【解决方案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

【讨论】：