使用公式未更改的VBA转置数据

Question

代码：

Sub transposeTest()
   Dim transposedVariant As Variant
   Dim sourceRowRange As Range
   Dim sourceRowRangeVariant As Variant

   Set sourceRowRange = Selection
   sourceRowRangeVariant = sourceRowRange.Value
   transposedVariant = Application.Transpose(sourceRowRangeVariant)

   Dim rangeFilledWithTransposedData As Range
   Set rangeFilledWithTransposedData = Application.InputBox("Select cell to transpose selected data :", "Transpose Data", , , , , , 8) ' eight rows, one column
   rangeFilledWithTransposedData.Value = transposedVariant
End Sub

我需要使用公式转置的范围。

sourceRowRange是用户完成的选择，例如：image RangeFilledWithTransposedData是用户选择用于转置所选范围的单元格。用户希望灵活地选择转置范围，并且足够灵活，可以在当前工作表中的任何位置转置数据。

如您所见，D3是公式，即=B3*C3。同样，公式适用于Column D中的休息单元格。

现在，使用上面的代码我面临两个问题：
1.我必须选择输出单元格，您可以在代码中看到。但是当我这样做时，只有第一个值被粘贴在该输出单元格中，即该值被打印为＆＃34; 1＆＃34;来自B3。但是当我为输出单元选择一个范围时，例如与我的选择相同数量的单元格，然后我得到所有转置列。这意味着如果我选择2个细胞，那么只有2个细胞将被转置，如果我选择10个细胞，那么将转换10个细胞。它不会转移选择中的所有单元格，直到我提供与我的选择相同数量的单元格。

这些公式不能转换。只有来自column D的值才会被转置。有没有办法用各自的公式转置数据？

Answer 1

这应该有效：

Sub test()
Application.ScreenUpdating = False

Dim ws As Worksheet: Set ws = Worksheets("Sheet1") 'Type the sheet where the data is pasted
Dim myRows As Long
Dim myColumns As Long
Dim rng As Range
Dim userInput As String
Dim Outputrng As Range
Dim rowCounter As Long
Dim columnCounter As Long

myColumns = Selection.Columns.Count

userInput = InputBox("Type output cell eg. B10")
If userInput = vbNullString Then Exit Sub

rowCounter = 0
columnCounter = -1

For Each rng In Selection

    columnCounter = columnCounter + 1

    If columnCounter > myColumns - 1 Then columnCounter = -1

    If columnCounter = -1 Then
        rowCounter = rowCounter + 1
        columnCounter = 0
    End If

    Set Outputrng = ws.Range(userInput).Offset(columnCounter, rowCounter)

        If rng.HasFormula = True Then
           rng.Formula = Application.ConvertFormula(rng.Formula, xlA1, xlA1, 1)
        End If

    rng.Copy
    Outputrng.PasteSpecial xlPasteFormulas

Next

Application.ScreenUpdating = True
End Sub

请记住，如果您的公式使用相对单元格引用，则可能会得到意外结果。

代码说明：

myColumns = Selection.Columns.Count

上面的代码段存储了所选区域中的列数以供将来使用。

userInput = InputBox("Type output cell eg. B10")
If userInput = vbNullString Then Exit Sub

上面的代码片段会提示InputBox，用户可以在其中编写所需的输出单元格。输出单元格将成为转置数据的左上角单元格。 如果用户未键入值，If语句将退出sub。

For Each rng In Selection循环遍历所选范围内的每个单元格。代码首先从左到右循环遍历列，然后向下循环并再次循环遍历列。这个循环的一般想法是识别单元格的位置，然后将其粘贴到相应的转置位置。

columnCounter和rowCounter会跟踪单元格的位置。 columnCounter = 0和rowCounter = 0将成为第一个被转置的细胞。此单元格粘贴到用户指定的输出单元格。 columnCounter = 1和rowCounter = 0将成为第二个要转置的单元格。此单元格粘贴在同一列中，但输出单元格下方有一行。

在每个循环开始时，columnCounter的值增加1，可以在columnCounter = columnCounter + 1行看到。

当columnCounter的值变得大于myColumns的值时，columnCounter的值将设置为-1。当columnCounter的值为-1时，rowCounter的值增加1，columnCounter的值重置为0。这意味着循环已经完成了一行中的列，现在正在进入下一行 所有这些都可以在以下代码片段中看到：

If columnCounter > myColumns - 1 Then columnCounter = -1

If columnCounter = -1 Then
   rowCounter = rowCounter + 1
   columnCounter = 0
End If

现在确定了单元格的位置，我们需要将其粘贴到正确的“output range”，在代码中称为Outputrng。这在以下行中完成：

Set Outputrng = ws.Range(userInput).Offset(columnCounter, rowCounter)

此行的基础是Range(userInput)。这是用户通过InputBox指定的原始输出单元格。使用.Offset，我们可以使用相对于用户指定的输出单元格的单元格。由于我们需要转置原始选区，因此我们使用columnCounter和rowCounter来反转原始单元格的位置。
请注意，columnCounter用作row offset，而rowCounter用作column offset。

接下来，我们检查单元格是否包含公式。如果是，则将公式转换为绝对参考。这可以通过以下代码行完成：

If rng.HasFormula = True Then
   rng.Formula = Application.ConvertFormula(rng.Formula, xlA1, xlA1, 1)
End If

请注意，最后的1是指定我们想要绝对引用的内容。如果我们想要相对参考，只需将1更改为4。

最后一步是将原始单元格粘贴到Outputrng。为确保我们也粘贴公式，我们使用.PasteSpecial xlPasteFormulas。如果单元格不包含公式，则粘贴该值。这是在以下代码行上完成的：

rng.Copy
Outputrng.PasteSpecial xlPasteFormulas

使用Next告诉代码转到选择中的下一个单元格，在代码中称为rng。

这可能不是最简单或最优雅的方法，但这就是我会这样做的 - 它的确有效！ ：）