當前位置:成語大全網 - 新華字典 - excel vba翻譯?

excel vba翻譯?

Sub 制小表()

Dim d As Object '聲明變量

Dim ss$, n% '聲明變量

Range("A2:H" & [a65536].End(3).Row).Delete Shift:=xlUp '刪除A2至A列最後壹個非空單元格,到h列的區域,下方單元格上移

m = Sheet1.[d65536].End(xlUp).Row '獲取Sheet1d列最後壹個非空單元格行號

arr = Sheet1.Range("d1:h" & m) '將Sheet1d到h列數據讀入數組arr

Set d = CreateObject("scripting.dictionary") '創建字典

ReDim brr(1 To UBound(arr), 1 To 4) '創建二維數組brr

For i = 2 To UBound(arr) '這個循環的作用是將arr首列相同的數據合並後放入brr

ss = arr(i, 1)

If Not d.Exists(ss) Then

n = n + 1

d.Add ss, n

brr(n, 1) = arr(i, 1): brr(n, 2) = 1: brr(n, 3) = arr(i, 4): brr(n, 4) = arr(i, 5)

Else

brr(d(ss), 2) = brr(d(ss), 2) + 1

brr(d(ss), 3) = brr(d(ss), 3) & "|" & arr(i, 4)

brr(d(ss), 4) = brr(d(ss), 4) & "|" & arr(i, 5)

End If

Next

bt = [{"序號","","","數量","碼段","無碼段","碼段不清","戶數"}] '初始化數組bt

Columns("B:C").NumberFormatLocal = "@" '設置bc列為文本格式

d.RemoveAll '清除字典

ReDim crr(1 To (m - 1) + n * 3, 1 To 8) '創建二維數組crr

hs = 0

For i = 1 To n '這個循環為brr裏的每行數據制壹個表

For j = 1 To 8 '這個循環初始化表頭

crr(1 + hs, j) = bt(j)

Next

crr(1 + hs, 2) = brr(i, 1) '原表D列放到表頭第2列

p1 = Split(brr(i, 3), "|") '拆分

p2 = Split(brr(i, 4), "|") '拆分

For j = 1 To brr(i, 2) '這個循環將brr合並的壹行數據,重新拆分成原來的行數存入crr

crr(j + 1 + hs, 1) = j '第壹列為序號

crr(j + 1 + hs, 2) = p1(j - 1) '第2列為原表G列

crr(j + 1 + hs, 3) = p2(j - 1) '第3列為原表H列

ss = Right(crr(j + 1 + hs, 3), 6) '取原表H列數據右邊6位,沒有“*”且不重復的在第8列進行計數

If InStr(ss, "*") = 0 Then

If Not d.Exists(ss) Then

d.Add ss, ""

crr(j + 1 + hs, 8) = 1

crr(brr(i, 2) + 2 + hs, 8) = crr(brr(i, 2) + 2 + hs, 8) + 1

End If

End If

If InStr(crr(j + 1 + hs, 2) & crr(j + 1 + hs, 3), "*") = 0 Then '原表G、H列數據,沒有“*”在第5列進行計數,全是“*”在第6列進行計數,其余在第7列進行計數

crr(j + 1 + hs, 5) = 1

crr(brr(i, 2) + 2 + hs, 5) = crr(brr(i, 2) + 2 + hs, 5) + 1

Else

If Len(Replace(crr(j + 1 + hs, 2) & crr(j + 1 + hs, 3), "*", "")) = 0 Then

crr(j + 1 + hs, 6) = 1

crr(brr(i, 2) + 2 + hs, 6) = crr(brr(i, 2) + 2 + hs, 6) + 1

Else

crr(j + 1 + hs, 7) = 1

crr(brr(i, 2) + 2 + hs, 7) = crr(brr(i, 2) + 2 + hs, 7) + 1

End If

End If

crr(j + 1 + hs, 4) = 1

crr(brr(i, 2) + 2 + hs, 4) = crr(brr(i, 2) + 2 + hs, 4) + 1

Next

crr(brr(i, 2) + 2 + hs, 1) = "合計"

crr(brr(i, 2) + 3 + hs, 1) = "備註:卷煙" & crr(brr(i, 2) + 2 + hs, 4) & "條,碼段" & crr(brr(i, 2) + 2 + hs, 5) * 1 & "條,無碼段" & crr(brr(i, 2) + 2 + hs, 6) * 1 & "條,碼段不清" & crr(brr(i, 2) + 2 + hs, 7) * 1 & "條,涉及戶數" & crr(brr(i, 2) + 2 + hs, 8) * 1 & "戶"

d.RemoveAll

Cells(1, "a").Offset(brr(i, 2) + 1 + hs, 0).Resize(1, 3).Merge '合並單元格,每表倒數第二行前三列

Cells(1, "a").End(3).Offset(brr(i, 2) + 2 + hs, 0).Resize(1, 8).Merge '合並單元格,每表最後壹行8列

Cells(1, "a").End(3).Resize(1, 2).Offset(hs, 1).Merge '合並單元格,表頭2,3列,另外本行與上壹行代碼End(3).多余,有沒有效果壹樣,但是加上後影響運算速度

hs = hs + brr(i, 2) + 3 '表格總行數

Next

Cells(1, "a").Resize(UBound(crr), 8) = crr '將crr數據寫入單元格

Range("a1:h" & [a65536].End(3).Row).Borders.LineStyle = 1 '設置邊框

End Sub