|
|
楼主 |
发表于 2017-5-9 22:44
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
加入了字典写法
Private MaxRow2 As Integer, shtname As String
Sub data_Filter()
Dim Crng, MaxRow1 As Integer, Maxcol1 As Integer
shtname = Application.InputBox("请输入Oracle明细账名称", "输入名称", "201704月明细账")
ActiveSheet.Name = shtname
Application.DisplayAlerts = False
For Each wbsh In ActiveWorkbook.Sheets
If wbsh.Name = "研发费用本月明细" Then
wbsh.Delete
End If
Next
MaxRow1 = ActiveSheet.[A1].CurrentRegion.Rows.Count
Maxcol1 = ActiveSheet.[A1].CurrentRegion.Columns.Count
MaxRow2 = MaxRow1 + 100
Set Crng = Application.InputBox("条件单元格区域", "条件区域", "$I$901:$I$907", , , , , 8)
ActiveSheet.[A1].Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Range(Selection, Selection.End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Crng, _
CopyToRange:=Range("A" & MaxRow2), Unique:=False
Sheets.Add.Name = "研发费用本月明细"
Sheets(shtname).Select
Range("A" & MaxRow2).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("研发费用本月明细").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Sub Dataload()
Dim Rowmax1 As Integer
Dim Rowmax2 As Integer
Dim Rowmax3 As Integer
Dim I As Integer, J As Integer, m As Integer, R As Integer, W As Integer
Dim Rowmax4 As Integer, Rowmax5 As Integer
Dim wbsh As Worksheet
Dim arr(1 To 10000, 1 To 16) As Variant
Dim H As Integer
Dim arr1(1 To 10000, 1 To 16) As Variant
Application.ScreenUpdating = False
Rowmax1 = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
Rowmax2 = Rowmax1 + 2
Rowmax4 = Rowmax1 + 1
Application.DisplayAlerts = False
For Each wbsh In ActiveWorkbook.Sheets
If wbsh.Name = "Dataload" Then
wbsh.Delete
End If
Next
For I = 1 To Rowmax1
arr(I, 1) = Cells(I, 11) & "." & Cells(I, 12) & "." & Cells(I, 13) & "." & Cells(I, 15) & "." _
& Cells(I, 19) & "." & Cells(I, 20) & "." & Cells(I, 22) & "." & Cells(I, 23)
arr(I, 2) = "TAB"
arr(I, 3) = Cells(I, 27)
arr(I, 4) = "TAB"
arr(I, 5) = Cells(I, 7)
arr(I, 6) = "TAB"
arr(I, 7) = Cells(I, 31)
arr(I, 8) = arr(I, 6)
arr(I, 9) = Cells(I, 32)
arr(I, 10) = "TAB"
arr(I, 11) = Cells(I, 33)
arr(I, 12) = "TAB"
arr(I, 13) = Cells(I, 35)
arr(I, 14) = "TAB"
arr(I, 15) = Cells(I, 36)
arr(I, 16) = "ENT"
arr(1, 1) = "科目代码"
Next I
Sheets.Add.Name = "Dataload"
ActiveSheet.[A1].Resize(Rowmax1, 16) = arr
Set dic = CreateObject("scripting.dictionary")
For J = 1 To Rowmax1
If dic.exists(arr(J, 1)) Then
m = dic(arr(J, 1))
arr1(m, 3) = arr1(m, 3) + arr(J, 3)
Else
k = k + 1
For u = 1 To UBound(arr, 2)
dic(arr(J, 1)) = k
arr1(k, u) = arr(J, u)
Next u
End If
Next J
ActiveSheet.Range("A" & Rowmax2).Resize(Rowmax1, 16) = arr1
For R = 2 To Rowmax1
H = InStr(1, Cells(R, 1), 5301)
Cells(R, 1) = WorksheetFunction.Replace(Cells(R, 1), H, 6, 530101)
Next R
Rowmax3 = ActiveSheet.Range("A" & Rowmax2).CurrentRegion.Rows.Count
Rowmax5 = Rowmax2 + Rowmax3
For W = Rowmax2 + 1 To Rowmax5 - 1
Cells(W, 3) = -Cells(W, 3)
Next W
Rows(Rowmax4 & ":" & Rowmax2).Select
Selection.Delete Shift:=xlUp
Columns("A:P").Select
Columns("A:P").EntireColumn.AutoFit
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Sheets(shtname).Select
Rows(MaxRow2 & ":" & MaxRow2).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Sheets("Dataload").Select
Application.DisplayAlerts = True
End Sub
Sub call_all()
Call data_Filter
Call Dataload
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2017-5-6 02:00
