Question

我正在使用当前v查找来查找和放置特定项目的值。但是，我正在寻找有关VB宏的帮助，该宏将按定义的结果输出数据。

请参阅原始数据的第一个屏幕截图

第二个屏幕截图应该是结果。

请注意，“ site”不是常数，可以是任何值，因此我已将所有site放在A列中。

目前V外观做得很好。但有时会使文件崩溃。

Answer 1

您可以使用数据透视表使用原始数据源解决此问题，而表布局不会发生变化。

拖动列，如下所示（您将要使用默认名称重命名）：对于Columns，首先将Date字段拖到此处。将两个字段拖到“值”区域后，将出现Σ Values字段，该字段应位于Date下方。

对默认格式进行了一些更改，结果可能类似于：

Answer 2

您可以更改源数据吗？
如果您将数据更改为类似于下面的“已更改的源数据”表，则可以使用数据透视表解决问题。

具有数据透视表的解决方案

use pivot 2

更改了源数据

use pivot 1

Answer 3

使用数据透视表可以轻松解决该问题。为了练习，我创建了以下内容。

让我们假设：

数据出现在工作表“数据”中

结果将填充在“结果”表中

Option Explicit

Sub Allocation()

Dim LastRow As Long, Row As Long, Column As Long, Invetory As Long, Sold As Long, Remaining As Long, LastRowRes As Long, LastColRes As Long, CurrentCol As Long, CurrentRow As Long, i As Long, y As Long
Dim iDate As Date
Dim Site As String
Dim wsData As Worksheet, wsResults As Worksheet
Dim ExcistSite As Boolean, ExcistDate As Boolean

Set wsData = ThisWorkbook.Worksheets("Data")
Set wsResults = ThisWorkbook.Worksheets("Results")

LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row

wsResults.UsedRange.Clear

For Row = 2 To LastRow

    iDate = wsData.Cells(Row, 1).Value
    Site = wsData.Cells(Row, 2).Value
    Invetory = wsData.Cells(Row, 3).Value
    Sold = wsData.Cells(Row, 4).Value
    Remaining = wsData.Cells(Row, 5).Value

    If Row = 2 Then

        With wsResults.Range("B1:D1")
            .Merge
            .Value = iDate
        End With

        wsResults.Range("A2").Value = "Site"
        wsResults.Range("A2").Offset(1, 0).Value = Site
        wsResults.Range("B2").Value = "Invetory"
        wsResults.Range("B2").Offset(1, 0).Value = Invetory
        wsResults.Range("C2").Value = "Sold"
        wsResults.Range("C2").Offset(1, 0).Value = Sold
        wsResults.Range("D2").Value = "Remaining"
        wsResults.Range("D2").Offset(1, 0).Value = Remaining

    Else
        'Check if Site appears
        LastRowRes = wsResults.Cells(wsResults.Rows.Count, "A").End(xlUp).Row

        For i = 3 To LastRowRes
            ExcistSite = False
            If wsResults.Cells(i, 1).Value = Site Then
                CurrentRow = i
                ExcistSite = True
                Exit For
            Else
                CurrentRow = i + 1
            End If
        Next i

        If ExcistSite = False Then
            wsResults.Cells(CurrentRow, 1).Value = Site
        End If

        'Check if date appears
        LastColRes = wsResults.Cells(1, wsResults.Columns.Count).End(xlToLeft).Column

        For y = 2 To LastColRes
            ExcistDate = False
            If wsResults.Cells(1, y).Value = iDate Then
                CurrentCol = y
                ExcistDate = True
                Exit For
            Else
                CurrentCol = y + 1
            End If
        Next y

        If ExcistDate = False Then

            wsResults.Cells(2, CurrentCol + 2).Value = "Invetory"
            wsResults.Cells(i, CurrentCol + 2).Value = Invetory
            wsResults.Cells(2, CurrentCol + 3).Value = "Sold"
            wsResults.Cells(i, CurrentCol + 3).Value = Sold
            wsResults.Cells(2, CurrentCol + 4).Value = "Remaining"
            wsResults.Cells(i, CurrentCol + 4).Value = Remaining

            With wsResults.Range(Cells(1, LastColRes + 3), Cells(1, LastColRes + 5))
                .Merge
                .Value = iDate
            End With

        Else
            wsResults.Cells(CurrentRow, CurrentCol).Value = Invetory
            wsResults.Cells(CurrentRow, CurrentCol + 1).Value = Sold
            wsResults.Cells(CurrentRow, CurrentCol + 2).Value = Remaining
        End If

    End If

Next Row

LastColRes = wsResults.Cells(1, wsResults.Columns.Count).End(xlToLeft).Column
LastRowRes = wsResults.Cells(wsResults.Rows.Count, "A").End(xlUp).Row

With wsResults.Range(Cells(1, 2), Cells(1, LastColRes))
    With .Font
        .Bold = True
        .ThemeColor = xlThemeColorDark1
    End With
    With .Interior
        .ThemeColor = xlThemeColorAccent1
    End With
End With

With wsResults.Cells(2, 1)
    With .Font
        .Bold = True
        .ThemeColor = xlThemeColorDark1
    End With
    With .Interior
        .ThemeColor = xlThemeColorLight1
    End With
End With

For i = 2 To LastColRes Step 3

    With wsResults.Range(Cells(2, i), Cells(LastRowRes, i))

        With .Interior
            .ThemeColor = xlThemeColorAccent1
            .TintAndShade = 0.399975585192419
        End With

    End With

Next i

For i = 3 To LastColRes + 3 Step 3

    With wsResults.Range(Cells(2, i), Cells(LastRowRes, i + 1))

        With .Font
            .ThemeColor = xlThemeColorDark2
            .TintAndShade = -0.249977111117893
        End With

    End With

Next i

With wsResults.UsedRange
    .Borders.LineStyle = xlContinuous
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .EntireColumn.AutoFit
End With

End Sub

如何创建一个宏，使用条件将数据从行复制到列？

3 个答案: