[已解决]如果通过VBA自动生成这样的表？大神留步

lj3543711

如果通过VBA自动生成这样的表？大神留步

用图片说明了一下

附件已经打包上传
由于文件不能超过1MB  图片没有上传，请大神留下脚印
9.7销售明细(1).zip (822.24 KB, 下载次数: 18)

2022-9-8 13:53 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

我行我速2008

2022-9-8 15:59

如果代码较多，建议花点钱，有偿下。

跳转到最佳答案楼层

我行我速2008

如果代码较多，建议花点钱，有偿下。

lj3543711

我行我速2008 发表于 2022-9-8 15:59
如果代码较多，建议花点钱，有偿下。

是这个道理 哈哈

我行我速2008

先写段吧，销售表中的直营联营、女鞋、日期中有下拉箭头，选择后自动生成。

我行我速2008

Private Sub Worksheet_Activate()
    Call tt
    With Cells(1, 3).Validation
        .Delete
        For R = 2 To UBound(Ar)
            D(Ar(R, 17)) = ""
        Next R
        Ky = D.Keys
        Str = VBA.Join(Ky, ",")
        .Add Type:=3, AlertStyle:=1, Operator:=1, Formula1:=Str  '来自字符串
    End With
    D.RemoveAll
    With Cells(2, 3).Validation
        .Delete
        For R = 2 To UBound(Ar)
            D(Ar(R, 9)) = ""
        Next R
        Ky = D.Keys
        Str = VBA.Join(Ky, ",")
        .Add Type:=3, AlertStyle:=1, Operator:=1, Formula1:=Str  '来自字符串
    End With
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = Cells(1, 2).Address Or Target.Address = Cells(1, 3).Address Or Target.Address = Cells(2, 3).Address Then
        Call 销售表
    End If
End Sub

Public Ar, Br, Cr(), R&, C&, K&, I&, Str$
Public D As Object
Public Sub tt()
    Set D = CreateObject("scripting.dictionary")
    Ar = Sheets("report").[a1].CurrentRegion
    Br = Sheets("销售").Range("A1:O2")
    K = 0
End Sub
Public Sub 销售表()
    Call tt
    On Error Resume Next
    Sheets("销售").Range("A4").CurrentRegion.Offset(1, 0).ClearContents
    For R = 2 To UBound(Ar)
        If InStr(Br(1, 2), Ar(R, 6)) And Ar(R, 17) = Br(1, 3) And Ar(R, 9) = CDate(Br(2, 3)) Then
            If D.exists(Ar(R, 5)) Then
               I = D(Ar(R, 5))
               Cr(3, I) = Cr(3, I) + Ar(R, 25)
               Cr(4, I) = Cr(4, I) + Ar(R, 32)
               Cr(5, I) = Application.Round(Cr(4, I) / Cr(3, I), 2)
            Else
                K = K + 1
                D(Ar(R, 5)) = K
                ReDim Preserve Cr(1 To 5, 1 To K)
                Cr(1, K) = K
                Cr(2, K) = Ar(R, 5): Cr(3, K) = Ar(R, 25)
                Cr(4, K) = Ar(R, 32): Cr(5, K) = Application.Round(Cr(4, K) / Cr(3, K), 2)
            End If
        End If
    Next R
    With Sheets("销售")
        .Range("A5").Resize(K, 5) = Application.Transpose(Cr)
        R = .Cells(Rows.Count, 2).End(xlUp).Row + 1
        .Cells(R, 2) = "合计"
        .Cells(R, 3) = Application.Sum(Range("C5:C" & R))
        .Cells(R, 4) = Application.Sum(Range("D5:D" & R))
    End With
End Sub

我行我速2008

111111111111

我行我速2008

又写了点，不明白库存的数据来源，所以没写，不知图片名称，也没添加，需要的话可发过来看看。

我行我速2008

111111111111

lj3543711

我行我速2008 发表于 2022-9-11 20:12
又写了点，不明白库存的数据来源，所以没写，不知图片名称，也没添加，需要的话可发过来看看。

论坛这两天进不来，刚进来，嘿嘿 ，非常感谢您，我学个思路想高下jsa谢谢您