[已解决][求助]完美一下表格

zjsxzgx

已经有朋友帮我完成了第一步。本想自己研究一下。但自己水平实在太差

按朋友帮我完成的 【记录查阅】\ 【统计计算】上已经完成了 日期和数量的填写

现在我想更完美一下

在  【统计计算】的按钮上再加入型号的填写 同时完成最下面的单价填写

 

1wqbncyc.rar (24.88 KB, 下载次数: 12)

2010-2-4 14:06 上传

点击文件名下载附件
[求助]完美一下表格

最佳答案

月排行榜 / 总排行榜

amulee

2010-2-4 14:20

Private Sub CommandButton2_Click()
    Dim ArrXH, ArrYS, BZ, ArrJG, TempX, TempY
    Dim d As Object, i&, j&, K&
    On Error Resume Next
    '型号填写
    Sheet3.Range("B4").Resize(1, Sheet1.Range("F65536").End(xlUp).Row - 1) = Application.Transpose( _
        Sheet1.Range("F2:F" & Sheet1.Range("F65536").End(xlUp).Row))
    '单价填写
    Sheet3.Range("B30").Resize(1, Sheet1.Range("G65536").End(xlUp).Row - 1) = Application.Transpose( _
        Sheet1.Range("G2:G" & Sheet1.Range("G65536").End(xlUp).Row))
    Set d = CreateObject("Scripting.Dictionary")
    ArrYS = Sheet1.Range("A2:D" & Sheet1.Range("A65536").End(xlUp).Row)
    ArrXH = Range("B4:M4")
    BZ = Range("A2")
    ReDim ArrJG(1 To 13, 1 To 1)
    K = 0
    For i = 1 To UBound(ArrYS)
        If ArrYS(i, 1) = BZ Then
            If Not d.exists(ArrYS(i, 3)) Then
                K = K + 1
                ReDim Preserve ArrJG(1 To 13, 1 To K)
                d(ArrYS(i, 3)) = K
                ArrJG(1, K) = ArrYS(i, 3)
            End If
            TempY = d(ArrYS(i, 3))
            TempX = WorksheetFunction.Match(ArrYS(i, 2), ArrXH, 0) + 1
            If Err.Number <> 0 Then
                Err.Clear
            Else
                ArrJG(TempX, TempY) = ArrYS(i, 4) + ArrJG(TempX, TempY)
            End If
        End If
    Next
    Range("A5:M28").ClearContents
    Range("A5").Resize(UBound(ArrJG, 2), 13) = Application.Transpose(ArrJG)
End Sub

跳转到最佳答案楼层

amulee

Private Sub CommandButton2_Click()
    Dim ArrXH, ArrYS, BZ, ArrJG, TempX, TempY
    Dim d As Object, i&, j&, K&
    On Error Resume Next
    '型号填写
    Sheet3.Range("B4").Resize(1, Sheet1.Range("F65536").End(xlUp).Row - 1) = Application.Transpose( _
        Sheet1.Range("F2:F" & Sheet1.Range("F65536").End(xlUp).Row))
    '单价填写
    Sheet3.Range("B30").Resize(1, Sheet1.Range("G65536").End(xlUp).Row - 1) = Application.Transpose( _
        Sheet1.Range("G2:G" & Sheet1.Range("G65536").End(xlUp).Row))
    Set d = CreateObject("Scripting.Dictionary")
    ArrYS = Sheet1.Range("A2:D" & Sheet1.Range("A65536").End(xlUp).Row)
    ArrXH = Range("B4:M4")
    BZ = Range("A2")
    ReDim ArrJG(1 To 13, 1 To 1)
    K = 0
    For i = 1 To UBound(ArrYS)
        If ArrYS(i, 1) = BZ Then
            If Not d.exists(ArrYS(i, 3)) Then
                K = K + 1
                ReDim Preserve ArrJG(1 To 13, 1 To K)
                d(ArrYS(i, 3)) = K
                ArrJG(1, K) = ArrYS(i, 3)
            End If
            TempY = d(ArrYS(i, 3))
            TempX = WorksheetFunction.Match(ArrYS(i, 2), ArrXH, 0) + 1
            If Err.Number <> 0 Then
                Err.Clear
            Else
                ArrJG(TempX, TempY) = ArrYS(i, 4) + ArrJG(TempX, TempY)
            End If
        End If
    Next
    Range("A5:M28").ClearContents
    Range("A5").Resize(UBound(ArrJG, 2), 13) = Application.Transpose(ArrJG)
End Sub

zjsxzgx

这次不理想

要跳过空格（也就是说本次记录没有的）

amulee

Private Sub CommandButton2_Click()
    Dim ArrXH, ArrYS, BZ, ArrJG, TempX, TempY, ArrXHDJ
    Dim d As Object, dXH As Object, i&, j&, K&, N&
    On Error Resume Next
    '型号
    ArrXHDJ = Sheet1.Range("F2:G" & Sheet1.Range("F65536").End(xlUp).Row)
    Set d = CreateObject("Scripting.Dictionary")
    Set dXH = CreateObject("Scripting.Dictionary")
    ArrYS = Sheet1.Range("A2:D" & Sheet1.Range("A65536").End(xlUp).Row)
    BZ = Range("A2")
    ReDim ArrJG(1 To 13, 1 To 1)
    ReDim ArrXH(1 To 2, 1 To 1)
    K = 0
    N = 0
    For i = 1 To UBound(ArrYS)
        If ArrYS(i, 1) = BZ Then
            If Not d.exists(ArrYS(i, 3)) Then
                K = K + 1
                ReDim Preserve ArrJG(1 To 13, 1 To K)
                d(ArrYS(i, 3)) = K
                ArrJG(1, K) = ArrYS(i, 3)
            End If
            TempY = d(ArrYS(i, 3))
            '判断型号
            If Not dXH.exists(ArrYS(i, 2)) Then
                N = N + 1
                ReDim Preserve ArrXH(1 To 2, 1 To N)
                dXH(ArrYS(i, 2)) = N
                ArrXH(1, N) = ArrYS(i, 2)
                ArrXH(2, N) = WorksheetFunction.VLookup(ArrYS(i, 2), ArrXHDJ, 2, 0)
            End If
            TempX = dXH(ArrYS(i, 2)) + 1
            If Err.Number <> 0 Then
                Err.Clear
            Else
                ArrJG(TempX, TempY) = ArrYS(i, 4) + ArrJG(TempX, TempY)
            End If
        End If
    Next
    Range("A5:M28,B4:M4,B30:M30").ClearContents
    Range("A5").Resize(UBound(ArrJG, 2), 13) = Application.Transpose(ArrJG)
    Range("B4").Resize(1, UBound(ArrXH, 2)) = Application.Index(ArrXH, 1, 0)
    Range("B30").Resize(1, UBound(ArrXH, 2)) = Application.Index(ArrXH, 2, 0)
End Sub