常用代码归集

jsgj2023

=======================part15窗体=========================
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
n = ListBox1.Value
With ActiveSheet
    .Cells(ActiveCell.Row, 2) = Left(n, 4)
    pr = .Cells(ActiveCell.Row, 2).Offset(0, 10)
    .Cells(ActiveCell.Row, 9) = pr
    .Cells(ActiveCell.Row, 8).Activate
    Unload Me
End With
End Sub

Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
n = ListBox2.Value
With ActiveSheet
    .Cells(ActiveCell.Row, 2) = Left(n, 4)
    pr = .Cells(ActiveCell.Row, 2).Offset(0, 10)
    .Cells(ActiveCell.Row, 9) = pr
    .Cells(ActiveCell.Row, 8).Activate
    Unload Me
End With
End Sub

Private Sub ListBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
n = ListBox3.Value
With ActiveSheet
    .Cells(ActiveCell.Row, 2) = Left(n, 4)
    pr = .Cells(ActiveCell.Row, 2).Offset(0, 10)
    .Cells(ActiveCell.Row, 9) = pr
    .Cells(ActiveCell.Row, 8).Activate
    Unload Me
End With
End Sub

Private Sub ListBox4_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
n = ListBox4.Value
With ActiveSheet
    .Cells(ActiveCell.Row, 2) = Left(n, 4)
    pr = .Cells(ActiveCell.Row, 2).Offset(0, 10)
    .Cells(ActiveCell.Row, 9) = pr
    .Cells(ActiveCell.Row, 8).Activate
    Unload Me
End With
End Sub

Private Sub UserForm_Initialize()
On Error Resume Next
MultiPage1.Value = 0
With Sheets("商品信息")
    n = .[b1046576].End(3).Row
    For r = 2 To n
        If Left(.Cells(r, 9), 6) = "台式电脑" Then
            ListBox1.AddItem .Cells(r, 2) & "-" & .Cells(r, 3) & "-" & .Cells(r, 4)
        ElseIf Left(.Cells(r, 9), 6) = "笔记本电脑" Then
            ListBox1.AddItem .Cells(r, 2) & "-" & .Cells(r, 3) & "-" & .Cells(r, 4)
        ElseIf Left(.Cells(r, 9), 6) = "电脑配件" Then
            ListBox1.AddItem .Cells(r, 2) & "-" & .Cells(r, 3) & "-" & .Cells(r, 4)
        ElseIf Left(.Cells(r, 9), 6) = "电脑耗材" Then
            ListBox1.AddItem .Cells(r, 2) & "-" & .Cells(r, 3) & "-" & .Cells(r, 4)
    Next r
End With
End Sub

jsgj2023

357楼至371楼,为一个完整的库存管理系统代码!
本楼将在时机成熟时贴附件!

jsgj2023

Sub 遍历文件夹提取信息()
Dim arr(1 To 100) As String
Dim arr1(1 To 100000, 1 To 6) As String
Dim fso  As Object
Dim myfile As Object
arr(1) = ThisWorkbook.Path & "\"
i = 1: k = 1
Do While i < UBound(arr)
    If arr(i) = "" Then Exit Do
    f = Dir(arr(i), vbDirectory)
    Do
        If InStr(f, ".") = 0 And f <> "" Then
            k = k + 1
            arr(k) = arr(i) & f & "\"
        End If
        f = Dir
    Loop Until f = ""
    i = i + 1
Loop
Set fso = CreateObject("scripting.filesystemobject")
For x = 1 To UBound(arr)
    If arr(x) = "" Then Exit For
    f3 = Dir(arr(x) & "*.*")
    Do While f3 <> ""
        q = q + 1
        arr1(q, 6) = arr(x) & f3
        Set myfile = fso.getfile(arr1(q, 6))
        arr1(q, 1) = f3
        With myfile
            arr1(q, 2) = .Size: arr1(q, 3) = .datecreated
            arr1(q, 4) = .datelastmodified: arr1(q, 5) = .datelastaccessed
            f3 = Dir
      End With
    Loop
Next x
Range("a2").Resize(1000, 6) = ""
Range("a2").Resize(q, 6) = arr1
End Sub

jsgj2023

2017/3/10修正
Sub 苏宁系统数量和金额匹配_以原始数据为基础()
If MsgBox("请选择苏宁系统各门店当期销售金额汇总工作簿," _
& "确保该簿中有《合并结果》表！", vbYesNo + vbQuestion + vbDefaultButton1) = vbYes Then
    GoTo 100
Else
    Exit Sub
End If
100:
'strfind = Application.InputBox("请输入当期销售报表的起始日期：", Type:=1)
strfind = Application.InputBox("请输入当期销售报表的起始日期：", "如20170115", Type:=1)
Dim d As Object, sh As Worksheet
Dim arr, brr, crr(), wb As Workbook
Dim x&, y&, z&, k&, i&, j&
Dim kNE As Variant
Dim kMc As Variant
Dim dStandard As Object
Dim arrStandard, xstd&, kFinal As Variant, sFinal As String
Dim dFinal  As Object, xFinal&
Dim arrFinal As Variant, n&, kk&, splFinal As Variant
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
Set dnow = CreateObject("scripting.dictionary")
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    If .Show Then p = .SelectedItems(1) Else: Exit Sub
End With
With GetObject(p)
    arr = .Sheets("合并结果").Range("a1").CurrentRegion
    .Close False
    For x = 2 To UBound(arr)
        If arr(x, 13) >= strfind Then
            If arr(x, 10) = "9019" Or arr(x, 10) = "8417" Then
                sell = arr(x, 10) & "+" & arr(x, 13) & "+" & arr(x, 16) '门店代码+销售时间+商品名称
                If Not d.exists(sell) Then
                    d(sell) = Array(arr(x, 17), arr(x, 18))
                Else
                    kNE = d(sell)
                    kNE(0) = kNE(0) + arr(x, 17) '结算数量
                    kNE(1) = kNE(1) + arr(x, 18) '结算金额
                    d(sell) = kNE
                End If
            End If
        End If
    Next
End With
'sj门店代码  9019
'sm门店代码  8417
Set wb = ActiveWorkbook
With wb
    brr = .Sheets("合并结果").Range("a1").CurrentRegion
    Application.DisplayAlerts = False
    For Each sh In .Sheets
        If sh.Name = "提取结果" Then sh.Delete
    Next
    Application.DisplayAlerts = True
    For y = 2 To UBound(brr)
        If brr(y, 3) = "9019" Or brr(y, 3) = "8417" Then
            nowsell = brr(y, 3) & "+" & brr(y, 1) & "+" & brr(y, 7) '门店代码+销售时间+商品名称
            dnow(nowsell) = dnow(nowsell) + brr(y, 9) '销售数量累加
        End If
    Next y
    anow = dnow.keys
    bnow = dnow.items
    ReDim crr(1 To UBound(anow) + 1, 1 To 4)
    For z = 0 To UBound(anow)
        k = k + 1
        crr(k, 1) = anow(z)
        crr(k, 2) = bnow(z)
    Next z
    For i = 1 To UBound(crr)
        If d.exists(crr(i, 1)) Then
            kMc = d(crr(i, 1))
            crr(i, 3) = kMc(0)
            crr(i, 4) = kMc(1)
        End If
    Next i
    ReDim Preserve crr(1 To UBound(crr), 1 To UBound(crr) + 6)
    '==============型号标准数据=================
    Set dStandard = CreateObject("scripting.dictionary")
    With GetObject("C:\Users\Administrator\AppData\Roaming\Microsoft\AddIns" & "\单品名称和型号标准数据表.xlsx")
        arrStandard = .Sheets("苏宁系统结算平台型号整理-字典法").[a1].CurrentRegion
        .Close False
    End With
    For xstd = 2 To UBound(arrStandard)
        If Not dStandard.exists(arrStandard(xstd, 1)) Then
            dStandard(arrStandard(xstd, 1)) = arrStandard(xstd, 2)
        End If
    Next
    '==============型号标准数据=================
    For j = 1 To UBound(crr)
        spl = Split(crr(j, 1), "+")
        crr(j, 5) = spl(0)
        crr(j, 6) = spl(1)
        crr(j, 7) = spl(2)
        If dStandard.exists(crr(j, 7)) Then
            crr(j, 8) = dStandard(crr(j, 7))
        Else
            crr(j, 8) = crr(j, 7)
        End If
    Next j
  '============对提取的金额和数量分类汇总=====================
      Set dFinal = CreateObject("scripting.dictionary")
      For xFinal = 1 To UBound(crr)
        sFinal = crr(xFinal, 5) & "+" & crr(xFinal, 8)
        If Not dFinal.exists(sFinal) Then
            dFinal(sFinal) = Array(crr(xFinal, 2), crr(xFinal, 3), crr(xFinal, 4))
        Else
            kFinal = dFinal(sFinal)
            kFinal(0) = kFinal(0) + crr(xFinal, 2)
            kFinal(1) = kFinal(1) + crr(xFinal, 3)
            kFinal(2) = kFinal(2) + crr(xFinal, 4)
            dFinal(sFinal) = kFinal
        End If
      Next
      afinal = dFinal.keys
      bfinal = dFinal.items
      ReDim arrFinal(1 To UBound(afinal) + 1, 1 To 5)
      For n = 0 To UBound(afinal)
        kk = kk + 1
        splFinal = Split(afinal(n), "+")
        arrFinal(kk, 1) = splFinal(0)
        arrFinal(kk, 2) = splFinal(1)
        arrFinal(kk, 3) = bfinal(n)(0)
        arrFinal(kk, 4) = bfinal(n)(1)
        arrFinal(kk, 5) = bfinal(n)(2)
      Next
      '============对提取的金额和数量分类汇总=====================
    .Sheets.Add(after:=Sheets(Sheets.Count)).Name = "提取结果"
    With .Sheets("提取结果")
        .[a1].Resize(1, 5) = Array("门店代码", "商品名称", "销售数量", "结算数量", "结算金额")
        .[a2].Resize(UBound(arrFinal), UBound(arrFinal, 2)) = arrFinal
        .Range("a:g").EntireColumn.AutoFit
    End With
End With
MsgBox "OK!若B列包含中文,那么型号数据不存在于<苏宁系统结算平台型号整理-字典法>中,请添加!"""
Application.ScreenUpdating = True
End Sub

jsgj2023

Dim k&, h%, arr, t#, r&
Dim brr$(1 To 1048576, 1 To 1)
Sub 给定一组数求指定值的所有组合()
      k = 0: t = Timer: Erase brr: h = [c1]
      r = Cells(Rows.Count, 1).End(3).Row
      arr = Range("a2:a" & r)
      Call Adele_dg(1, 0, "")
      Range("d1").Resize(k) = brr
      MsgBox "找到 " & k & " 个解!花费" & Format(Timer - t, "0.00") & "秒"
End Sub
Sub Adele_dg(x%, z%, str$)
      If z + arr(x, 1) = h Then k = k + 1: brr(k, 1) = str & arr(x, 1) & "=" & h: Exit Sub
      If x < UBound(arr) And z < h Then
      If z + arr(x, 1) < h Then Call Adele_dg(x + 1, z + arr(x, 1), str & arr(x, 1) & "+")
            Call Adele_dg(x + 1, z, str)
      End If
End Sub

好难注册

太崇拜了，膜拜一下

jsgj2023

Sub 安得库存和BMS库存核对()'4.0版'
    Dim d As Object, ws  As Worksheet
    Dim L As Variant
    Dim dBMS As Object
    Dim Result As String

     If MsgBox("请先打开BMS库存表格,程序须以此为基础!", vbYesNo + vbQuestion + vbDefaultButton1) = vbYes Then
            GoTo 100
            Else
            Exit Sub
        End If
100:

    On Error GoTo 10000
    L = Application.InputBox("先选择【商品编码】所在的列,再选择CCS库存表格", "温馨提示", Type:=8).Column
    On Error GoTo 0
    Application.ScreenUpdating = False
   
    Set d = CreateObject("scripting.dictionary")
    Set dBMS = CreateObject("scripting.dictionary")
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        If .Show Then p = .SelectedItems(1) Else: Exit Sub
    End With
    With GetObject(p)
        arr = .Sheets(1).Range("a1").CurrentRegion 'CCS数据表装入数组arr
        For x = 2 To UBound(arr)
            If Not d.exists(arr(x, 4)) Then
                d(arr(x, 4)) = arr(x, 7) * 1
            End If
        Next x
        .Close False
    End With
'    Set ws = Sheets(1)
Set ws = ActiveSheet
    With ws
        brr = .Range("a1").CurrentRegion 'BMS数据表装入数组brr
        c = UBound(brr, 2) + 1
            For y = 2 To UBound(brr)
                If d.exists(brr(y, L)) Then Cells(y, c) = d(brr(y, L))
                If Not dBMS.exists(brr(y, 4)) Then dBMS(brr(y, 4)) = ""
            Next y
            
            For a = 2 To UBound(arr)
                If Not dBMS.exists(arr(a, 4)) Then s = s & "," & arr(a, 4)
            Next
          Result = Mid(s, 2)
        
'    With .Range("a1").CurrentRegion
'        .Borders.LineStyle = 1
'        .HorizontalAlignment = xlCenter
'    End With
    Application.ScreenUpdating = True
      End With
10000:

MsgBox "CCS数据表中的以下【商品编码】不存在于BMS数据表中。" & vbCrLf & Result, vbInformation + vbOKOnly, "提示"
End Sub

km122712

感谢分享！

EH2003

jsgj2023 发表于 2017-7-13 17:26
Sub 安得库存和BMS库存核对()'4.0版'
    Dim d As Object, ws  As Worksheet
    Dim L As Variant

应当附上实例。

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