Question

相当冗长的标题，但基本上我有一个像这样的表

我希望找到每个数据点与相同行上每个其他数据点之间的增量，对于每个行。

例如，对于26/03/2018，我希望得到：

Red-Blue（5-2），
Red-Green（5-4），
Red-Purple（5-3），
Red-N/A（N/A），
Red-Yellow（5-5），
Blue-Green（2-4），
Blue-Purple（2-3），
等

然后，我想在所有行上重复此操作，以查看颜色对差异的值如何随日期变化，如下表所示。

到目前为止，我已经尝试通过填充一个行并循环遍历它，将结果输出到另一个工作表来为一行做这个，但我对VBA完全不熟悉并且不熟悉我得到的大量错误运行这个宏。

Public Sub ReadToArray()
Dim ForwardData As Variant
ForwardData = Sheets("Sheet1").Range("D8:GF8").Value
Dim i As Integer
Dim j As Integer
Dim MaxVal As Integer
Dim SwapArray As Variant
MaxVal = UBound(ForwardData) - LBound(ForwardData) + 1
 For i = 1 To MaxVal
        For j = i + 1 To MaxVal
            SwapArray = ForwardData(i) - ForwardData(j)
        Next j
    Next i



Sheets("Sheet2").Range("D").Value = SwapArray

End Sub

到目前为止，我的问题似乎是那个

我不知道如何在行之间循环
当我只想与N / A进行任何比较时，N / A值会引发错误N / A
引用创建的行数组中的位置，例如'ForwardData（i）'会创建错误

感谢阅读！

Answer 1

下面的代码将自动调整为更多列和行（颜色和日期）
主要锚点是topCell，因此，如果您的表格从D8开始，请更新此行：

Set topCell = ws1.Cells(2, 2)    'B2

到

Set topCell = ws1.Cells(8, 4)    'D8

并且该单元格应为空。

为避免出现任何问题，请创建一个新的通用VBA模块并将此代码粘贴到其中

Option Explicit

Public Sub ShowDelta()
    Dim ws1 As Worksheet, ws2 As Worksheet, topCell As Range

    Set ws1 = Sheet1
    Set ws2 = Sheet2
    Set topCell = ws1.Cells(2, 2)       'Main cell - B2

    Dim ur1tbl As Range, ur1Arr As Variant
    Set ur1tbl = GetUsedRange(topCell)  'topCell should be empty
    If ur1tbl Is Nothing Then Exit Sub

    With ur1tbl
        Set topCell = .Cells(1)
        Set ur1tbl = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
        ur1Arr = ur1tbl
    End With

    Dim hHdr1Rng As Range, vHdr1Rng As Range, hHdr2Arr As Variant, vHdr2Arr As Variant
    SetHeaders topCell, hHdr1Rng, vHdr1Rng      'updates hHdr1Rng and vHdr1Rng
    hHdr2Arr = GetDateHorizontalHeaders(vHdr1Rng)
    vHdr2Arr = GetColorVerticalHeaders(hHdr1Rng)

    Dim ws2hHdr As Range, ws2vHdr As Range, ur2rng As Range, ur2Arr As Variant
    SetWs2Areas ws2, topCell, hHdr2Arr, vHdr2Arr, ws2hHdr, ws2vHdr, ur2rng
    ws2hHdr = hHdr2Arr
    ws2vHdr = vHdr2Arr

    ur2Arr = ur2rng
    ur2Arr = GetDelta(ur1Arr, ur2Arr) 'updates ur2Arr
    ur2rng = ur2Arr
    ws2.UsedRange.Columns.AutoFit
    ur2rng.HorizontalAlignment = xlCenter
End Sub

Private Function GetUsedRange(ByRef firstCell As Range) As Range
    If Not firstCell Is Nothing Then
        Set GetUsedRange = firstCell.CurrentRegion   'Top-left cell (1st row & 1st col)
        If GetUsedRange.CountLarge = 1 Then
            Set GetUsedRange = Nothing
            Exit Function
        End If
    End If
End Function

Private Function SetHeaders(ByVal topCell As Range, _
                            ByRef hHdr As Range, _
                            ByRef vHdr As Range) As Boolean
    Dim hHdr1 As Range, hHdrMax As Long, vHdr1 As Range, vHdrMax As Long

    Set hHdr1 = topCell.Offset(0, 1)
    Set vHdr1 = topCell.Offset(1, 0)
    hHdrMax = hHdr1.End(xlToRight).Column
    vHdrMax = vHdr1.End(xlDown).Row
    With topCell.Parent
        Set hHdr = .Range(hHdr1, .Cells(topCell.Row, hHdrMax))
        Set vHdr = .Range(vHdr1, .Cells(vHdrMax, topCell.Column))
    End With
End Function

Private Function GetDateHorizontalHeaders(ByVal dtHdr As Range) As Variant
    Dim hHdr As Variant, vHdrMax As Long, i As Long

    vHdrMax = dtHdr.Rows.Count
    ReDim hHdr(1 To 1, 1 To vHdrMax)
    For i = 1 To vHdrMax
        hHdr(1, i) = IIf(IsError(dtHdr(i, 1)), "N/A", dtHdr(i, 1).Value2)
    Next
    GetDateHorizontalHeaders = hHdr
End Function

Private Function GetColorVerticalHeaders(ByVal clrHdr As Range) As Variant
    Dim vHdr As Variant, vHdrMax As Long, hHdrMax As Long

    hHdrMax = clrHdr.Columns.Count
    vHdrMax = hHdrMax * (hHdrMax - 1) \ 2   'max combinations
    ReDim vHdr(1 To vHdrMax, 1 To 1)

    Dim i As Long, j As Long, k As Long, val1 As String, val2 As String
    k = 1
    For i = 1 To hHdrMax
        For j = i + 1 To hHdrMax
            val1 = IIf(IsError(clrHdr(1, i)), "N/A", clrHdr(1, i).Value2)
            val2 = IIf(IsError(clrHdr(1, j)), "N/A", clrHdr(1, j).Value2)
            vHdr(k, 1) = val1 & " - " & val2
            k = k + 1
        Next j
    Next i
    GetColorVerticalHeaders = vHdr
End Function

Private Function SetWs2Areas(ByVal ws As Worksheet, ByVal topCell As Range, _
                             ByRef h As Variant, v As Variant, _
                             ByRef hHdr As Range, ByRef vHdr As Range, _
                             ByRef ur As Range) As Boolean
    Dim row1 As Long, col1 As Long, ws2TopLeft As Range, ws2BottomRight As Range
    Dim ws2BottomRightRow As Long, ws2BottomRightCol As Long

    col1 = topCell.Column
    row1 = topCell.Row

    With ws    'Sheet2 vertical and horizontal headers
        Set hHdr = .Range(.Cells(row1, col1 + 1), .Cells(row1, UBound(h, 2) + col1))
        Set vHdr = .Range(.Cells(row1 + 1, col1), .Cells(UBound(v) + row1, col1))
    End With

    Set ws2TopLeft = ws.Cells(hHdr.Row + 1, vHdr.Column + 1)

    ws2BottomRightRow = vHdr.Row + vHdr.Rows.Count - 1
    ws2BottomRightCol = hHdr.Column + hHdr.Columns.Count - 1

    Set ws2BottomRight = ws.Cells(ws2BottomRightRow, ws2BottomRightCol)

    Set ur = ws.Range(ws2TopLeft, ws2BottomRight)
End Function

Private Function GetDelta(ByVal ur1 As Variant, ByVal ur2 As Variant) As Variant
    Dim ur1Rows As Long, ur1Cols As Long, ur2Rows As Long, ur2Cols As Long

    ur1Rows = UBound(ur1, 1)
    ur1Cols = UBound(ur1, 2)

    Dim r1 As Long, r2 As Long, c2 As Long, i As Long, j As Long
    Dim v1 As Variant, v2 As Variant

    r2 = 1
    c2 = 1

    For r1 = 1 To ur1Rows
        For i = 1 To ur1Cols
            For j = i + 1 To ur1Cols

                v1 = IIf(IsError(ur1(r1, i)), "N/A", ur1(r1, i))
                v2 = IIf(IsError(ur1(r1, j)), "N/A", ur1(r1, j))

                If IsNumeric(v1) And IsNumeric(v2) Then
                    ur2(r2, c2) = v1 - v2
                Else
                    ur2(r2, c2) = IIf(IsNumeric(v1), v2, v1)
                End If
                r2 = r2 + 1
            Next
        Next
        r2 = 1
        c2 = c2 + 1
    Next
    GetDelta = ur2
End Function

这是我的测试表（Sheet1）

结果，在Sheet2上

Answer 2

这是我的解决方案。我首先找到最后占用的行和列，然后使用计数器循环遍历表本身来创建Deltas。然后将它们输出到表格上，就像上面的例子一样。

 Private Sub CommandButton1_Click()

 Dim Col As Long
 Dim Row As Long
 Dim Col1 As Long
 Dim Row1 As Long
 Dim Counter As Long

 'Find the last used row in a Column in Sheet1
Dim LastRow As Long
With Sheet1
     LastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
 End With
 'Find the last used column in a Row in Sheet1
Dim LastCol As Integer
With Sheet1
    LastCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
End With

Counter = 4
For Col = 4 To LastCol
    For Col1 = Col To LastCol - 1
        Worksheets("Sheet2").Cells(Counter, 4) = Format(Worksheets("Sheet1").Cells(3, Col), "mm/dd/yyyy") + "-" + Format(Worksheets("Sheet1").Cells(3, Col1 + 1), "mm/dd/yyyy")
        Counter = Counter + 1
    Next Col1
Next Col

Counter = 4
For Row = 5 To LastRow
    For Col = 4 To LastCol - 1
        For Col1 = Col To LastCol - 1
            If IsNumeric(Worksheets("Sheet1").Cells(Row, Col)) And IsNumeric(Worksheets("Sheet1").Cells(Row, Col1 + 1)) Then
                Worksheets("Sheet2").Cells(Counter, Row) = Worksheets("Sheet1").Cells(Row, Col) - Worksheets("Sheet1").Cells(Row, Col1 + 1)
            Else
                Worksheets("Sheet2").Cells(Counter, Row) = "N/A"
            End If
            Counter = Counter + 1
        Next Col1
    Next Col
    Counter = 4
Next Row

End Sub

使用日期和颜色比较一段时间内的变化

2 个答案: