class UserForm1
Option Explicit
Private Sub btnBillDir_Click()
Me.txtBillDir.Text = GetFolder()
End Sub
Private Sub btnCiam_Click()
Dim fileNameObj
fileNameObj = Excel.Application.GetOpenFilename("Excel文件(*.xlsx),*.xlsx")
If fileNameObj <> False Then
Me.txtCiam.Text = fileNameObj
End If
End Sub
Private Sub CommandButton2_Click()
If Me.txtBillDir.Text <> "" And Me.txtCiam.Text <> "" And Me.txtZq.Text <> "" Then
Me.Hide
Execute Me.txtBillDir, Me.txtCiam.Text, Me.txtZq.Text
Unload Me
End If
End Sub
Private Sub UserForm_Initialize()
Me.txtZq = Format(DateAdd("M", -1, Now()), "yyyyMM")
End Sub
end class
class ALCatelogClass
Option Explicit
Private m_sheet As Worksheet
Private m_Items As Collection
Private m_fl As String '分类
Public Sub Init(vsheet As Worksheet)
Set m_sheet = vsheet
m_fl = vsheet.Name
Dim i
Dim mitem As AlCatelogItemClass
Set m_Items = New Collection
For i = 2 To vsheet.UsedRange.Rows.Count
Set mitem = New AlCatelogItemClass
With mitem
.Init vsheet, i
End With
m_Items.Add mitem
Set mitem = Nothing
Next
End Sub
'填充ciam金额/复制改名为简称/写入金额
Sub Fill(destDir, ciamDict, billDict)
If m_Items Is Nothing Then Exit Sub
If m_Items.Count = 0 Then Exit Sub
'文件写入到工作簿
Dim wb As Workbook, summarySht As Worksheet, fileName
Set wb = Workbooks.Add
fileName = destDir & "\" & m_fl & ".xlsx"
wb.SaveAs fileName
'汇总表
Set summarySht = wb.Sheets(1)
summarySht.Name = m_fl & "汇总表"
WriteHeader m_sheet, summarySht
'写ciam金额及金额，复制文件
Dim element
For Each element In m_Items
element.WriteCiamJe ciamDict
element.WriteBill wb, billDict, m_sheet, summarySht
'Debug.Print element.jc & "/" & element.yjzh
Next
'汇总表合计及格式
summarySht.Activate
SetSummaryStyle summarySht
wb.Save
'保存工作簿
wb.Close
End Sub
'写表头
Private Sub WriteHeader(pSht As Worksheet, curSht As Worksheet)
Dim rng As Range
Set rng = pSht.Range("B1,C1,D1,E1,F1,I1")
rng.Copy curSht.Range("A1")
Set rng = Nothing
End Sub
Private Sub SetSummaryStyle(sht As Worksheet)
Dim max, rng As Range
max = sht.Cells(sht.Cells.Rows.Count, "A").End(xlUp).Row
Set rng = sht.Cells(max + 1, "E")
rng.value = "合计"
rng.HorizontalAlignment = xlHAlignCenter
rng.Offset(0, 1).Formula = "=SUM(F2:F" & max & ")"
sht.UsedRange.EntireColumn.AutoFit
With sht.Range(sht.Cells(1, 1), sht.Cells(max + 1, "F"))
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Interior.Color = RGB(255, 255, 255)
End With
Set rng = Nothing
End Sub
Private Sub class_Initialize()
' Called automatically when class is created
End Sub
Private Sub class_Terminate()
Set m_sheet = Nothing
Set m_Items = Nothing
End Sub
end class
class AlCatelogItemClass
Option Explicit
Private m_sht As Worksheet
Private m_yjzh As String
Private m_LineNo As Long
Private m_jc As String
Public Property Get yjzh() As String
yjzh = m_yjzh
End Property
Public Property Let yjzh(value As String)
m_yjzh = value
End Property
Public Property Get jc() As String
jc = m_jc
End Property
Public Property Let jc(value As String)
m_jc = value
End Property
Public Property Get LineNo() As Long
LineNo = m_LineNo
End Property
Public Property Let LineNo(value As Long)
m_LineNo = value
End Property
Public Sub Init(vsht, i)
Set m_sht = vsht
m_LineNo = i
m_yjzh = m_sht.Cells(i, "B")
m_jc = m_sht.Cells(i, "E")
End Sub
'填充Ciam金额
Sub WriteCiamJe(ciamDict)
If ciamDict.exists(m_yjzh) Then
m_sht.Cells(m_LineNo, "H") = ciamDict(m_yjzh)
End If
End Sub
' 金额列 填充 路径
Sub WriteBill(wb As Workbook, billDict, pSht, summarySht)
Dim fileName
Dim wbBill As Workbook, shtBill As Worksheet
If billDict.exists(m_yjzh) Then
fileName = billDict(m_yjzh)
Set wbBill = Workbooks.Open(fileName)
Set shtBill = wbBill.Worksheets(1)
m_sht.Cells(m_LineNo, "I") = GetJe(shtBill)
'复制并且改名为简称
shtBill.Copy after:=wb.Worksheets(wb.Worksheets.Count)
ActiveSheet.Name = Me.jc
wbBill.Close
Set shtBill = Nothing
Set wbBill = Nothing
'写汇总表表体
WriteSummary pSht, summarySht, m_LineNo
End If
End Sub
Private Sub WriteSummary(pSht, summarySht, pLineNum)
Dim rng As Range
Set rng = pSht.Range("B" & pLineNum & ",C" & pLineNum & ",D" & pLineNum & ",E" & pLineNum & ",F" & pLineNum & ",I" & pLineNum)
rng.Copy summarySht.Range("A" & (summarySht.UsedRange.Rows.Count + 1))
Set rng = Nothing
End Sub
Private Function GetJe(sht As Worksheet) As String
GetJe = GetRegExp(sht.Range("G6"), "为：([0-9.]+)，")
End Function
Private Sub class_Initialize()
' Called automatically when class is created
End Sub
Private Sub class_Terminate()
Set m_sht = Nothing
End Sub
end class
class CiamClass
Option Explicit
Private m_khzq As String
Private m_Wbname As String
Private m_Dict As Object
Public Property Get Khzq() As String
Khzq = m_khzq
End Property
Public Property Let Khzq(value As String)
m_khzq = value
End Property
Public Property Get Wbname() As String
Wbname = m_Wbname
End Property
Public Property Let Wbname(value As String)
m_Wbname = value
End Property
Public Property Get dict() As Object
Set dict = m_Dict
End Property
Public Property Set dict(value As Object)
Set m_Dict = value
End Property
Public Sub Init(fname As String, zq As String)
Me.Khzq = zq
Me.Wbname = fname
End Sub
Public Function GetCiamJeDict()
Dim wb, sht, dict1
Set wb = Workbooks.Open(Me.Wbname)
Set sht = wb.Worksheets(1)
Dim i, bp, zq, je, dict
Set dict1 = CreateObject("Scripting.Dictionary")
For i = 2 To sht.UsedRange.Rows.Count
bp = sht.Cells(i, "G")
zq = sht.Cells(i, "O")
je = sht.Cells(i, "K")
If zq = Me.Khzq And Not dict1.exists(bp) Then
dict1(bp) = je
End If
Next
Set sht = Nothing
wb.Close False
Set wb = Nothing
Set Me.dict = dict1
Set GetCiamJeDict = dict1
End Function
Public Sub Display()
Dim ele
For Each ele In Me.dict
Debug.Print ele & " / " & Me.dict(ele)
Next
End Sub
Private Sub class_Initialize()
' Called automatically when class is created
End Sub
Private Sub class_Terminate()
' Called automatically when all references to class instance are removed
End Sub
end class
class Common
Option Explicit
'在桌面生成日期时间的文件夹
Function GetDeskTopTimeDir()
Dim sj, oWShell, desktopPath, fullpath
sj = Format(Now(), "yyyyMMdd_hhmmss")
Set oWShell = CreateObject("WScript.Shell")
With oWShell
desktopPath = .specialfolders("Desktop")
End With
fullpath = desktopPath & "\" & sj
If dir(fullpath) = "" Then
MkDir fullpath
End If
GetDeskTopTimeDir = fullpath
End Function
'返回选择的目录（单个）
Public Function GetFolder() As String
Dim fdo
Set fdo = Excel.Application.FileDialog(msoFileDialogFolderPicker)
With fdo
.Title = "请选择文件夹"
.Show
If .SelectedItems.Count = 1 Then
GetFolder = .SelectedItems(1)
Set fdo = Nothing
Exit Function
End If
End With
Set fdo = Nothing
GetFolder = ""
End Function
Function GetFilesDict(path)
Dim dict, fileName
Set dict = CreateObject("Scripting.Dictionary")
fileName = dir(path & "\*.*")
Do While fileName <> ""
dict(GetYjzh(fileName)) = path & "\" & fileName
fileName = dir()
Loop
Set GetFilesDict = dict
Exit Function
End Function
Function GetYjzh(str)
Dim reg, mc, m
Set reg = CreateObject("vbscript.regexp")
reg.Pattern = "_(\d{10})-"
reg.Global = True
Set mc = reg.Execute(str)
For Each m In mc
GetYjzh = m.submatches.Item(0)
Exit Function
Next
End Function
'根据正则提取字符串
Function GetRegExp(str, regExp)
Dim reg, mc, m
Set reg = CreateObject("vbscript.regexp")
reg.Pattern = regExp '"_(\d{10})-"
reg.Global = True
Set mc = reg.Execute(str)
For Each m In mc
GetRegExp = m.submatches.Item(0)
Exit Function
Next
GetRegExp = ""
End Function
end class
class Main
Option Explicit
Sub Main()
UserForm1.Show
End Sub
Sub Execute(billdir As String, ciamFilename As String, zq As String)
' billdir
' ciam filename
' khzq
If billdir = "" Or ciamFilename = "" Or zq = "" Then Exit Sub
Dim currWb, actsht As Worksheet
Set currWb = ActiveWorkbook
Dim billFileDict
Set billFileDict = GetFilesDict(billdir)
Dim destDir
destDir = GetDeskTopTimeDir()
'Ciam字典
Dim ciam, tdict, i
Set ciam = New CiamClass
With ciam
.Init ciamFilename, zq
Set tdict = .GetCiamJeDict()
End With
Set ciam = Nothing
Dim alc
For Each actsht In currWb.Worksheets
Set alc = New ALCatelogClass
With alc
.Init actsht
.Fill destDir, tdict, billFileDict
End With
Set alc = Nothing
Next
Shell "explorer " & destDir, vbNormalFocus
End Sub
end class
