Public Sub Basic_CodeFrame()
AppSettings
'On Error GoTo ErrHandler
Dim StartTime, UsedTime As Variant
StartTime = VBA.Timer
'Input code here Dim Wb As Workbook
Dim Sht As Worksheet
Dim OpenWb As Workbook
Dim OpenSht As Worksheet
Dim NewWb As Workbook
Dim NewSht As Worksheet
Dim Arr As Variant
Dim i As Long, j As Long
Dim EndRow As Long
Dim Brr()
Dim Crr()
Dim Drr()
Dim Index As Long
Dim Index1 As Long
Dim Index2 As Long
Dim OneKey As Variant Dim Title As Variant Dim FolderPath As String
Const FolderName As String = "原始文件"
Const OutPutName As String = "结果文件" Const OpFile1 As String = "台面补货d.xlsx"
Const OpFile2 As String = "品牌补货d.xlsx"
Const OpFile3 As String = "小类补货d.xlsx" Dim OpPath As String Const AName As String = "盘点"
Dim aFile As String, aPath As String
Const CName As String = "产品资料"
Dim cFile As String, cPath As String
Const BName As String = "库存"
Dim bFile As String, bPath As String
Const DName As String = "销售"
Dim dFile As String, dPath As String Dim aInfo(1 To 4) As Object
Dim bInfo(1 To 4) As Object
Dim cInfo(1 To 18) As Object
Dim dInfo(1 To 5) As Object
Dim dCate As Object '小类
Dim dBrand As Object '品牌
Dim Cate As String
Dim Brand As String
Set dCate = CreateObject("Scripting.Dictionary")
Set dBrand = CreateObject("Scripting.Dictionary") Set Wb = Application.ThisWorkbook
Set Sht = Wb.Worksheets("标题")
Title = Sht.Range("A1:X1").Value
FolderPath = Wb.Path & Application.PathSeparator & _
FolderName & Application.PathSeparator '先到C表保存各种字段信息 For j = 1 To 18
Set cInfo(j) = CreateObject("Scripting.Dictionary")
Next j cFile = Dir(FolderPath & "*" & CName & "*.xls*")
cPath = FolderPath & cFile
Debug.Print cPath Set OpenWb = Application.Workbooks.Open(cPath)
Set OpenSht = OpenWb.Worksheets(1)
With OpenSht
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range("A2:R" & EndRow)
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
Key = CStr(Arr(i, 1))
Key = Replace(Key, " ", "")
For j = LBound(Arr, 2) To UBound(Arr, 2)
cInfo(j)(Key) = Arr(i, j)
Next j
Next i
End With
Set OpenSht = Nothing
OpenWb.Close False '再到A表读取报货单
For j = 1 To 4
Set aInfo(j) = CreateObject("Scripting.Dictionary")
Next j aFile = Dir(FolderPath & "*" & AName & "*.xls*")
aPath = FolderPath & aFile
Debug.Print aPath Set OpenWb = Application.Workbooks.Open(aPath)
Set OpenSht = OpenWb.Worksheets(1) With OpenSht
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range("A2:D" & EndRow)
Arr = Rng.Value For i = LBound(Arr) To UBound(Arr)
Key = CStr(Arr(i, 1))
Key = Replace(Key, " ", "")
For j = LBound(Arr, 2) To UBound(Arr, 2)
aInfo(j)(Key) = Arr(i, j)
Next j
Next i End With
Set OpenSht = Nothing
OpenWb.Close False '再到B表读取库存
For j = 1 To 4
Set bInfo(j) = CreateObject("Scripting.Dictionary")
Next j bFile = Dir(FolderPath & "*" & BName & "*.xls*")
bPath = FolderPath & bFile
Debug.Print bPath Set OpenWb = Application.Workbooks.Open(bPath)
Set OpenSht = OpenWb.Worksheets(1) With OpenSht
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range("A2:D" & EndRow)
Arr = Rng.Value For i = LBound(Arr) To UBound(Arr)
Key = CStr(Arr(i, 1))
Key = Replace(Key, " ", "")
For j = LBound(Arr, 2) To UBound(Arr, 2)
bInfo(j)(Key) = Arr(i, j)
Next j
Next i End With
Set OpenSht = Nothing
OpenWb.Close False '再到D表读取销售
For j = 1 To 5
Set dInfo(j) = CreateObject("Scripting.Dictionary")
Next j dFile = Dir(FolderPath & "*" & DName & "*.xls*")
dPath = FolderPath & dFile
Debug.Print dPath Set OpenWb = Application.Workbooks.Open(dPath)
Set OpenSht = OpenWb.Worksheets(1) With OpenSht
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range("A2:D" & EndRow)
Arr = Rng.Value For i = LBound(Arr) To UBound(Arr)
Key = CStr(Arr(i, 1))
Key = Replace(Key, " ", "")
For j = LBound(Arr, 2) To UBound(Arr, 2)
dInfo(j)(Key) = Arr(i, j)
Next j
Next i End With
Set OpenSht = Nothing
OpenWb.Close False '保存上报品牌与小类
'For Each OneKey In aInfo(1).keys
'Brand = cInfo(6)(OneKey) '保存品牌
'dBrand(Brand) = ""
'Cate = cInfo(4)(OneKey) '保存小类
'dCate(Cate) = ""
'Next OneKey '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '计算台面补货
ReDim Brr(1 To 24, 1 To 1)
Index = 0
For Each OneKey In aInfo(1).keys
Index = Index + 1
ReDim Preserve Brr(1 To 24, 1 To Index)
Brr(1, Index) = OneKey & " " '条码
Brr(2, Index) = cInfo(2)(OneKey) '商品名称2
Brr(3, Index) = IIf(aInfo(4)(OneKey) = "", 0, aInfo(4)(OneKey)) '商场库存4
Brr(4, Index) = IIf(bInfo(3)(OneKey) = "", 0, bInfo(3)(OneKey)) '总部库存3
Brr(5, Index) = IIf(dInfo(3)(OneKey) = "", 0, dInfo(3)(OneKey)) '销售数量3
Brr(6, Index) = cInfo(6)(OneKey) '品牌6
Brr(7, Index) = cInfo(4)(OneKey) '小类4 Brand = cInfo(6)(OneKey) '保存品牌
dBrand(Brand) = ""
Cate = cInfo(4)(OneKey) '保存小类
dCate(Cate) = "" Brr(8, Index) = (Brr(5, Index) - Brr(3, Index)) * 1.5 '(D-A)*1.5 要出多少货
If Brr(8, Index) > 0 Then
If Brr(4, Index) >= Brr(8, Index) Then '库存足够出货
Brr(9, Index) = Brr(8, Index) '直接出货
Brr(10, Index) = "" '无需采购
Else
Brr(9, Index) = Brr(4, Index) '库存全出
Brr(10, Index) = Brr(8, Index) - Brr(4, Index) '计算采购
End If
End If
'------
Brr(11, Index) = cInfo(3)(OneKey) '大类
Brr(12, Index) = cInfo(5)(OneKey) '规格
For j = 1 To 12
Brr(j + 12, Index) = cInfo(j + 6)(OneKey)
Next j
Next OneKey '创建台面补货文件
OpPath = Wb.Path & "\" & OutPutName & "\" & Replace(OpFile1, "d", "-" & Split(dFile, ".")(0))
Debug.Print OpPath Set NewWb = Application.Workbooks.Add()
Set NewSht = NewWb.Worksheets(1)
NewSht.Name = Split(OpFile1, "d")(0)
NewWb.SaveAs OpPath
With NewSht
.Columns("A:A").NumberFormat = "@"
.Range("A1:X1").Value = Title
.Range("a2").Resize(Index, 24).Value = _
Application.WorksheetFunction.Transpose(Brr)
End With NewWb.Close True
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '计算品牌与小类补货
ReDim Crr(1 To 24, 1 To 1)
ReDim Drr(1 To 24, 1 To 1) Index1 = 0
Index2 = 0
For Each OneKey In cInfo(1).keys Brand = cInfo(6)(OneKey) '保存品牌
If dBrand.Exists(Brand) Then '属于改品牌
Index1 = Index1 + 1
ReDim Preserve Crr(1 To 24, 1 To Index1)
Crr(1, Index1) = OneKey & " " '条码
Crr(2, Index1) = cInfo(2)(OneKey) '商品名称2
Crr(3, Index1) = IIf(aInfo(4)(OneKey) = "", 0, aInfo(4)(OneKey)) '商场库存4
Crr(4, Index1) = IIf(bInfo(3)(OneKey) = "", 0, bInfo(3)(OneKey)) '总部库存3
Crr(5, Index1) = IIf(dInfo(3)(OneKey) = "", 0, dInfo(3)(OneKey)) '销售数量3
Crr(6, Index1) = cInfo(6)(OneKey) '品牌6
Crr(7, Index1) = cInfo(4)(OneKey) '小类4
Crr(8, Index1) = (Crr(5, Index1) - Crr(3, Index1)) * 1.5 '(D-A)*1.5 要出多少货
If Crr(8, Index1) > 0 Then
If Crr(4, Index1) >= Crr(8, Index1) Then '库存足够出货
Crr(9, Index1) = Crr(8, Index1) '直接出货
Crr(10, Index1) = "" '无需采购
Else
Crr(9, Index1) = Crr(4, Index1) '库存全出
Crr(10, Index1) = Crr(8, Index1) - Crr(4, Index1) '计算采购
End If
End If
'------
Crr(11, Index1) = cInfo(3)(OneKey) '大类
Crr(12, Index1) = cInfo(5)(OneKey) '规格
For j = 1 To 12
Crr(j + 12, Index1) = cInfo(j + 6)(OneKey)
Next j
End If
Cate = cInfo(4)(OneKey) '保存小类
If dCate.Exists(Cate) Then
Index2 = Index2 + 1
ReDim Preserve Drr(1 To 24, 1 To Index2)
Drr(1, Index2) = OneKey & " " '条码
Drr(2, Index2) = cInfo(2)(OneKey) '商品名称2
Drr(3, Index2) = IIf(aInfo(4)(OneKey) = "", 0, aInfo(4)(OneKey)) '商场库存4
Drr(4, Index2) = IIf(bInfo(3)(OneKey) = "", 0, bInfo(3)(OneKey)) '总部库存3
Drr(5, Index2) = IIf(dInfo(3)(OneKey) = "", 0, dInfo(3)(OneKey)) '销售数量3
Drr(6, Index2) = cInfo(6)(OneKey) '品牌6
Drr(7, Index2) = cInfo(4)(OneKey) '小类4
Drr(8, Index2) = (Drr(5, Index2) - Drr(3, Index2)) * 1.5 '(D-A)*1.5 要出多少货
If Drr(8, Index2) > 0 Then
If Drr(4, Index2) >= Drr(8, Index2) Then '库存足够出货
Drr(9, Index2) = Drr(8, Index2) '直接出货
Drr(10, Index2) = "" '无需采购
Else
Drr(9, Index2) = Drr(4, Index2) '库存全出
Drr(10, Index2) = Drr(8, Index2) - Drr(4, Index2) '计算采购
End If
End If
'------
Drr(11, Index2) = cInfo(3)(OneKey) '大类
Drr(12, Index2) = cInfo(5)(OneKey) '规格
For j = 1 To 12
Drr(j + 12, Index2) = cInfo(j + 6)(OneKey)
Next j
End If Next OneKey '创建品牌补货文件
OpPath = Wb.Path & "\" & OutPutName & "\" & Replace(OpFile2, "d", "-" & Split(dFile, ".")(0))
Debug.Print OpPath Set NewWb = Application.Workbooks.Add()
Set NewSht = NewWb.Worksheets(1)
NewSht.Name = Split(OpFile2, "d")(0)
NewWb.SaveAs OpPath
With NewSht
.Columns("A:A").NumberFormat = "@"
.Range("A1:X1").Value = Title
.Range("a2").Resize(Index, 24).Value = _
Application.WorksheetFunction.Transpose(Crr)
End With NewWb.Close True '创建小类补货文件
OpPath = Wb.Path & "\" & OutPutName & "\" & Replace(OpFile3, "d", "-" & Split(dFile, ".")(0))
Debug.Print OpPath Set NewWb = Application.Workbooks.Add()
Set NewSht = NewWb.Worksheets(1)
NewSht.Name = Split(OpFile3, "d")(0)
NewWb.SaveAs OpPath
With NewSht
.Columns("A:A").NumberFormat = "@"
.Range("A1:X1").Value = Title
.Range("a2").Resize(Index, 24).Value = _
Application.WorksheetFunction.Transpose(Drr)
End With NewWb.Close True UsedTime = VBA.Timer - StartTime
'Debug.Print "UsedTime：" & Format(UsedTime, "0.000 Seconds")
MsgBox "UsedTime：" & Format(UsedTime, "0.000 Seconds"), vbOKOnly, "NS QQ "
ErrorExit:
AppSettings False
Exit Sub
ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Description & "！", vbCritical, "NS QQ "
Debug.Print Err.Description
Err.Clear
Resume ErrorExit
End If
End Sub
Public Sub AppSettings(Optional IsStart As Boolean = True)
If IsStart Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.StatusBar = ">>>>>>>>Macro Is Running>>>>>>>>"
Else
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End If
End Sub