常用代码归集

jsgj2023

Sub 一键CCS库存核销V2()
    Dim ar As Variant 'BMS苏国通检测表
    Dim br As Variant 'CCS当前库存表
    Dim d1 As Object, dsum As Object, dbr As Object
    Dim x&, s$, cr, y&, z&, s1$, k&
    Dim aSum, bSum, aBr, bBr
    Dim arRes '结果存放数组
    Dim nResult&
    Dim lSpl '拆分存在于CCS数据表中的型号
    Dim d5 As Object '修正商品编码和商品名称
    Dim k5 '记录最终输出至工作表的行数
    Dim ConToNum As Integer 'BMS数据表的销售数量由文本转换为数值型
   
    Set d1 = CreateObject("scripting.dictionary") '检查CCS数据表中的型号是否能与BMS数据表的型号一一对应
    Set d5 = CreateObject("scripting.dictionary")
    Set dsum = CreateObject("scripting.dictionary") 'BMS数据表处理
    Set dbr = CreateObject("scripting.dictionary") 'CCS数据表处理
   
    ActiveSheet.[a1].Resize(65530, 18).ClearContents '清空原有的数据区域
    ActiveSheet.[a1].Resize(, 18).Font.ColorIndex = 0

    If MsgBox("下面请将当月BMS苏国通检测表装入数组ar!", vbYesNo + vbQuestion + vbDefaultButton1) = vbYes Then GoTo 10 Else Exit Sub
10:
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        If .Show Then p = .SelectedItems(1) Else: Exit Sub
    End With
   
    With GetObject(p): ar = .Sheets(1).[a1].CurrentRegion: .Close False: End With 'BMS数据表装入数组ar
   
    For x = 2 To UBound(ar)
    ConToNum = ar(x, 9) * 1 'BMS数据表的销售数量由文本转换为数值型
        If InStr(ar(x, 7), "通程") Then
            s = "K00056076" & "," & "长沙通程控股股份有限公司株洲县通程电器渌口向阳广场店" & "," & "CRSW054" & "," & "通程电器代销仓" & "," & ar(x, 4): If Not dsum.exists(s) Then dsum(s) = ar(x, 9) * 1 Else dsum(s) = dsum(s) + ar(x, 9) * 1
        ElseIf InStr(ar(x, 7), "国美") Then
            s = "K00093487" & "," & "湖南国美电器有限公司株洲美的时代广场店" & "," & "CRSW055" & "," & "国美电器代销仓" & "," & ar(x, 4): If Not dsum.exists(s) Then dsum(s) = ar(x, 9) * 1 Else dsum(s) = dsum(s) + ar(x, 9) * 1
        ElseIf InStr(ar(x, 7), "苏宁") Then
            s = "K00056093" & "," & "株洲苏宁云商商贸有限公司攸县步行街连锁店" & "," & "CRSW050" & "," & "苏宁店代销仓" & "," & ar(x, 4): If Not dsum.exists(s) Then dsum(s) = ar(x, 9) * 1 Else dsum(s) = dsum(s) + ar(x, 9) * 1
        End If
    Next x

   
    If MsgBox("下面请将当月CCS库存表装入数组br!", vbYesNo + vbQuestion + vbDefaultButton1) = vbYes Then GoTo 100 Else Exit Sub
100:
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        If .Show Then p = .SelectedItems(1) Else: Exit Sub
    End With
   
    With GetObject(p): br = .Sheets(1).[a1].CurrentRegion: .Close False: End With 'CCS数据表装入数组br
   
    With GetObject("C:\Users\Administrator\AppData\Roaming\Microsoft\AddIns" & "\单品名称和型号标准数据表.xlsx")
        cr = .Sheets("CCS系统型号与BMS系统型号匹配数据库").[a1].CurrentRegion: .Close False
    End With
   
    '把型号标准数据装入字典d1
    For y = 2 To UBound(cr): d1(cr(y, 1)) = cr(y, 2): Next
   
    ReDim Preserve br(1 To UBound(br), 1 To UBound(br, 2) + 1) 'ccs数据表型号检查
   
    For z = 2 To UBound(br)
        If d1.exists(br(z, 5)) Then br(z, UBound(br, 2)) = d1(br(z, 5)) Else s1 = s1 & "第" & z & "行" & br(z, 5) & vbCr
    Next '检查CCS数据表中的型号是否能与BMS数据表的型号一一对应
   
    For x1 = 2 To UBound(br) '将CCS数据表的型号分门店求和
        If Len(br(x1, 13)) Then
            If InStr(br(x1, 2), "通程") Then
                sbr = "K00056076" & "," & "长沙通程控股股份有限公司株洲县通程电器渌口向阳广场店" & "," & "CRSW054" & "," & "通程电器代销仓" & "," & br(x1, 13): If Not dbr.exists(sbr) Then dbr(sbr) = br(x1, 8) Else dbr(s) = dbr(s) + br(x, 8)
            ElseIf InStr(br(x1, 2), "国美") Then
                sbr = "K00093487" & "," & "湖南国美电器有限公司株洲美的时代广场店" & "," & "CRSW055" & "," & "国美电器代销仓" & "," & br(x1, 13): If Not dbr.exists(sbr) Then dbr(sbr) = br(x1, 8) Else dbr(s) = dbr(s) + br(x, 8)
            ElseIf InStr(br(x1, 2), "苏宁") Then
                sbr = "K00056093" & "," & "株洲苏宁云商商贸有限公司攸县步行街连锁店" & "," & "CRSW050" & "," & "苏宁店代销仓" & "," & br(x1, 13): If Not dbr.exists(sbr) Then dbr(sbr) = br(x1, 8) Else dbr(s) = dbr(s) + br(x, 8)
            End If
        End If
    Next
   
    aSum = dsum.keys: bSum = dsum.items  '读取BMS数据表关键字和键值
    aBr = dbr.keys: bBr = dbr.items '读取CCS数据表关键字和键值
   
    'ReDim arRes(1 To UBound(aBr), 1 To 18) '待导入模板列数为18
      ReDim arRes(1 To 65530, 1 To 18) '待导入模板列数为18
    For x3 = 0 To UBound(aSum) '如果BMS中的数据存在于CCS中  则执行下面程序
        If dbr.exists(aSum(x3)) Then
            k1 = k1 + 1
            lSpl = Split(aSum(x3), ",")
            m = dbr(aSum(x3)) 'CCS中的数量
            n = bSum(x3) * 1 'BMS中的数量
            If m > n Then nResult = n Else nResult = m
                arRes(k1, 2) = lSpl(0): arRes(k1, 3) = lSpl(1): arRes(k1, 4) = lSpl(2): arRes(k1, 11) = lSpl(2)
                arRes(k1, 5) = lSpl(3): arRes(k1, 12) = lSpl(3): arRes(k1, 10) = lSpl(4): arRes(k1, 6) = "JVSUO0001"
                arRes(k1, 7) = "长沙市容声电器经销有限公司": arRes(k1, 13) = nResult: arRes(k1, 17) = "否"
        End If
    Next
   
    '==========================处理单据号=====================
    EndD = DateSerial(Year(DateSerial(Year(Now()), Month(Now()) - 1, _
    Day(Now()))), Month(DateSerial(Year(Now()), Month(Now()) - 1, Day(Now()))) + 1, 0)
    NoTC = "CRSC" & Format(EndD, "yymmdd") & "001"
    NoSN = "CRSC" & Format(EndD, "yymmdd") & "002"
    NoGM = "CRSC" & Format(EndD, "yymmdd") & "003"
   
    For x4 = 1 To UBound(arRes)
        If arRes(x4, 2) = "K00056093" Then '苏宁
            arRes(x4, 1) = NoSN
        ElseIf arRes(x4, 2) = "K00093487" Then '国美
            arRes(x4, 1) = NoGM
        ElseIf arRes(x4, 2) = "K00056076" Then '通程
            arRes(x4, 1) = NoTC
        End If
    Next
      '==========================处理单据号=====================
      
      '=====================处理商品名称和商品编码====================
      For x5 = 2 To UBound(br)
        If Len(br(x5, 13)) Then If Not d5.exists(br(x5, 13)) Then d5(br(x5, 13)) = Array(br(x5, 4), br(x5, 5))
      Next

      For x6 = 1 To UBound(arRes)
        If d5.exists(arRes(x6, 10)) Then: k5 = k5 + 1: m1 = d5(arRes(x6, 10)): arRes(x6, 9) = "'" & m1(0): arRes(x6, 10) = m1(1)
      Next
      '=====================处理商品名称和商品编码====================
   
    With ActiveSheet
    .[a1].Resize(, UBound(arRes, 2)) = [{"单据号","客户编码","客户名称","代销仓头表编码","代销仓头表名称","部门编码","部门名称","备注","商品编码","商品名称","代销仓行表编码","代销仓行表名称","结算量","单价(折前)","折扣率","折扣金额","是否赠品","行表备注"}]
    .[a2].Resize(k5, UBound(arRes, 2)) = arRes
    .[a1].Font.ColorIndex = 3:  .[b1].Font.ColorIndex = 3
    .[d1].Font.ColorIndex = 3: .[f1].Font.ColorIndex = 3
    .[i1].Font.ColorIndex = 3: .[k1].Font.ColorIndex = 3
    .[m1].Font.ColorIndex = 3: .[q1].Font.ColorIndex = 3
    .Cells.Font.Size = 9
    .Cells.EntireColumn.AutoFit
    .[a1].CurrentRegion.Borders.LineStyle = 1
  End With
  
  MsgBox s1
  MsgBox "OK!若上面的信息中包含型号,说明该型号在CCS数据表中有而BMS数据表中无,请至加载宏下完善[CCS系统型号与BMS系统型号匹配数据库]"
  'MsgBox s1 & "OK！", vbInformation + vbOKOnly, "若下面的信息中包含型号,说明该型号在CCS数据表中有而BMS数据表中无,请至加载宏下完善[CCS系统型号与BMS系统型号匹配数据库]"
End Sub

jsgj2023

Sub 找出被套码型号的明细()
    Dim d As Object, arr, s$, a%, b%, x%
    Set d = CreateObject("scripting.dictionary")
    arr = Range("a1").CurrentRegion
   
    For a = 2 To UBound(arr)
        For b = 8 To 20
            s = UCase(arr(a, b)): If s <> "" And Not IsNumeric(s) Then d(s) = d(s) + arr(a, b + 1)
        Next
    Next

    For x = 2 To UBound(arr)
        If d.Exists(UCase(arr(x, 1))) And arr(x, 6) < 0 Then Cells(x, 6) = Cells(x, 6) + d(UCase(arr(x, 1)))
    Next
   
End Sub

guski216

好好珍藏，留个印记

happymojo

楼主要是能整理出一个所有事例的目录列表就好了, 这样便于检索.
谢谢分享~

jsgj2023

Sub 每月销售报表按区域分类汇总()
    Dim ws  As Worksheet, d As Object
    Dim arr, brr, crr, d1 As Object, x%, y%
    Dim a%, b%, c%, L%, r%, r1%, s1, s2
    Set ws = ActiveSheet
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    For a = 1 To 2: Columns("a").Insert Shift:=xlToRight: Next
    Range("a2").Resize(, 2) = Array("分区域汇总", "区域")
    myPath = "C:\Users\Administrator\AppData\Roaming\Microsoft\AddIns"
    Application.ScreenUpdating = False
    Workbooks.OpenText (myPath & "\单品名称和型号标准数据表.xlsx")
    With ActiveWorkbook
        arr = .Sheets("销售报表门店按区域分类汇总").[a1].CurrentRegion: .Close
    End With
   
    For x = 1 To UBound(arr)
        If Not d.exists(arr(x, 1)) Then d(arr(x, 1)) = arr(x, 2)
    Next
   
    With ws
        brr = .Range("a1").CurrentRegion
        For y = 3 To UBound(brr)
            If d.exists(brr(y, 3)) Then brr(y, 2) = d(brr(y, 3))
        Next
        .Range("b1").Resize(UBound(brr), 1) = Application.Index(brr, 0, 2)
        r = .Cells(.Rows.Count, 2).End(xlUp).Row
        L = .Cells(3, .Columns.Count).End(xlToLeft).Column
        .Range(.Cells(2, 2), Cells(r, L)).Sort key1:=.Range("b2"), order1:=xlDescending, Header:=xlYes
        
        crr = Range("a1").CurrentRegion
        For b = 3 To UBound(crr)
            If Len(crr(b, 2)) Then d1(crr(b, 2)) = d1(crr(b, 2)) + crr(b, L)
         Next
         
         s1 = d1.keys: s2 = d1.items
         For a = 3 To 2 * r
            If .Cells(a + 1, 2) <> .Cells(a, 2) And Len(.Cells(a, 2)) And Not IsNumeric(.Cells(a, 2)) Then
                .Rows(a + 1).Insert: k = k + 1
                .Cells(a + 1, 1).Resize(, 2) = Array(s1(k - 1) & "汇总", s2(k - 1))
            End If
         Next
        
         r1 = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
        .Cells(r1, 1).Resize(, 2) = Array("总计", Application.Sum(s2))
    '格式调整
        .Range(.Cells(1, 1), Cells(r1, L)).Borders.LineStyle = xlContinuous
        .Range("a1").Resize(1, 29).Merge
        .Columns("a:az").AutoFit
        .Range(.Cells(1, 1), Cells(r1, L)).HorizontalAlignment = xlCenter
        .Range("a:b").Font.Bold = True
        .Range(.Cells(1, 1), Cells(r1, L)).Font.Size = 11
        .Range("a2").Select
    End With
     Application.ScreenUpdating = True
End Sub

zgs_8

天天更新，不错

UQKUN

感谢分享，留个印记

UQKUN

谢谢共享！， 辛苦了。

jsgj2023

Sub 一键制作透视表式统计表9()
    Dim r%, i%, arr, brr, d As Object, j&
    Application.DisplayAlerts = False
    pp = Split(ActiveWorkbook.Name, ".")(0)
    Set d = CreateObject("scripting.dictionary")
    With Worksheets(1)
        r = .Cells(Rows.Count, 1).End(xlUp).Row
        brr = .Range("a2:w" & r)
        .Range("a1:w" & r).Sort key1:=.Range("h1"), order1:=xlAscending, key2:=.Range("b1"), _
        order2:=xlAscending, key3:=.Range("c1"), order3:=xlAscending, Header:=xlYes
        arr = .Range("a2:w" & r)
        .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
        For i = 1 To UBound(arr)
            If arr(i, 2) <> "综合组织" Then
                If Len(arr(i, 2)) Then
                    If Not d.exists(arr(i, 8)) Then Set d(arr(i, 8)) = CreateObject("scripting.dictionary")
                    If Not d(arr(i, 8)).exists(arr(i, 2)) Then Set d(arr(i, 8))(arr(i, 2)) = CreateObject("scripting.dictionary")
                    'd(arr(i, 8))(arr(i, 2))(arr(i, 3)) = d(arr(i, 8))(arr(i, 2))(arr(i, 3)) + arr(i, 18)
                    '======================================================
                    '20170915修订
                         If Not d(arr(i, 8))(arr(i, 2)).exists(arr(i, 3)) Then
                            d(arr(i, 8))(arr(i, 2))(arr(i, 3)) = Array(arr(i, 18), arr(i, 13))
                         Else
                            k = d(arr(i, 8))(arr(i, 2))(arr(i, 3))
                            k(0) = k(0) + arr(i, 18)
                            k(1) = k(1) & "/" & arr(i, 13) '历次进价串联
                            d(arr(i, 8))(arr(i, 2))(arr(i, 3)) = k
                         End If
                    '======================================================
                End If
            End If
        Next i
    End With
For j = Sheets.Count To 2 Step -1: Sheets(j).Delete: Next j
    kk = d.keys
    For i = 0 To UBound(kk) - 1
        p = i
        For j = i + 1 To UBound(kk)
            If Val(kk(p)) > Val(kk(j)) Then p = j
        Next j
        If p <> i Then
            temp = kk(i): kk(i) = kk(p): kk(p) = temp
        End If
    Next i
    For i = 0 To UBound(kk)
        Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        With ws
            .Name = kk(i): .Range("a1") = "仓库名称": .Range("b1") = kk(i): .Range("c1") = pp
            .Range("a2:d2") = Array("中文型号", "英文型号", "期间结存数量", "进货单价")
            For Each bb In d(kk(i)).keys
                    r = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                    .Cells(r, 1) = bb
                    '.Cells(r, 2).Resize(d(kk(i))(bb).Count, 2) = Application.Transpose(Array(d(kk(i))(bb).keys, d(kk(i))(bb).items))
                    '===============================
                     '20170915修订
                        .Cells(r, 2).Resize(d(kk(i))(bb).Count) = Application.Transpose(d(kk(i))(bb).keys)
                        .Cells(r, 3).Resize(d(kk(i))(bb).Count, 2) = Application.Transpose(Application.Transpose(d(kk(i))(bb).items))
                    '===============================
            Next bb
            r = .Cells(Rows.Count, 2).End(3).Row
            .Range("a2:d" & r).Borders.LineStyle = 1
            .Columns("a:d").AutoFit
        End With
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

jsgj2023

考勤数据处理
Sub Adele()
    Dim d  As Object, d1 As Object, mypath$, brr, x&, y&, z&
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Sheets("刷卡记录_操作").Select
    mypath = ThisWorkbook.Path
    Workbooks.OpenText (mypath & "\原始记录数据_201709301.xlsx")
    With ActiveWorkbook
        arr = .Sheets("Sheet_20171001084604").[a1].CurrentRegion: .Close
    End With
    For x = 3 To UBound(arr)
        mo = Month(arr(x, 4))
        da = Day(arr(x, 4))
        ts = Left(Split(arr(x, 4), " ")(1), 5)
        s = arr(x, 2) & "," & mo & "," & da
        d(s) = d(s) & "," & ts
    Next
    r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    kqrq = Mid([c3], 6, 2) * 1
    brr = Sheets("刷卡记录_操作").Range("a1:ae" & r)
    For y = 5 To r Step 2
        For z = 1 To 31
            ss = brr(y, 11) & "," & kqrq & "," & brr(4, z)
                If d.exists(ss) Then
                    s2 = Split(d(ss), ",")
                    For m = 0 To UBound(s2)
                        If s2(m) <> "" Then d1(s2(m)) = ""
                    Next
                    s4 = d1.keys
                    Call ShellRecSort(s4)
                    brr(y + 1, z) = Join(s4, vbCrLf)
                End If
                d1.RemoveAll
        Next
    Next
    [a1].Resize(UBound(brr), UBound(brr, 2)) = brr
    Application.ScreenUpdating = False
End Sub

Function ShellRecSort(s4)
    Dim h&, i&, k&, L&, u&
    L = LBound(s4)
    u = UBound(s4)
    h = (u - L + 1)
    Do
        h = (h \ 5) * 2 + 1
        Call InsertSort(s4, L, u, h)
    Loop Until h = 1
    ShellRecSort = s4
End Function

Sub InsertSort(trr, L&, u&, Optional h& = 1)
    Dim i&, j&, t
    For i = L + h To u
        t = trr(i)
        For j = i - h To L Step -h
            If trr(j) > t Then trr(j + h) = trr(j) Else Exit For
        Next
        trr(j + h) = t
    Next
End SubF:\z.技术提升\b.代码库\c.自己写的代码\考勤数据处理