[已解决]請問如何加總不同工作表的個數?

e2solo · 发表于 2011-10-27 21:47

老師好
我有兩張分屬不同工作表的表格,如下:
第一張表是個人專長
姓名專長
a 水電
b 機械
c 土木
d 水電
e 水電
f 機械
g 土木
h 機械
i 水電
j 土木
k 土木

第2張表是加入的公司

公司姓名
甲 a
甲 c
乙 e
乙 k
乙 b
甲 g
丙 i
甲 f
乙 d
乙 j

想要再另一張工作表計算各別公司所擁有專長人數表

公司水電機械土木
甲 1 1 2
乙 2 1 2
丙 1 0 0

我不想先合併這兩張工作表，請問要如何編寫代碼才能完成?
謝謝老師

最佳答案

月排行榜 / 总排行榜

mxg825

2011-10-28 11:51

本帖最后由 mxg825 于 2011-10-28 12:01 编辑

Sub 生成数据()
Dim D As New Dictionary, LD As New Dictionary, ID As New Dictionary '字典
Dim Arr1, Arr2, Arr3 '数组
Dim 列&, 行&, L&, R&, X& '行列号变量
Arr1 = Sheets("專長表").Range("a2:B" & Sheets("專長表").Range("a65536").End(xlUp).Row)
Arr2 = Sheets("所屬公司").Range("a2:B" & Sheets("所屬公司").Range("a65536").End(xlUp).Row)
L = 1: R = 1
LD("公司\專長") = L
For X = 1 To UBound(Arr1)
If Not LD.Exists(Arr1(X, 2)) Then
L = L + 1
LD(Arr1(X, 2)) = L
End If
D(Arr1(X, 1)) = LD(Arr1(X, 2))
Next
If L = 1 Then Exit Sub
Arr3 = Application.Transpose(LD.keyS)
For X = 1 To UBound(Arr2)
行 = D(Arr2(X, 2))
If ID.Exists(Arr2(X, 1)) Then
列 = ID(Arr2(X, 1))
Arr3(行, 列) = Arr3(行, 列) + 1
Else
R = R + 1
ID(Arr2(X, 1)) = R
ReDim Preserve Arr3(1 To L, 1 To R)
Arr3(1, R) = Arr2(X, 1)
Arr3(行, R) = 1
End If
Next
Sheets("生成").Cells.Clear
Sheets("生成").Range("A1").Resize(R, L) = Application.Transpose(Arr3)
MsgBox "完成", , "mxg825提示"
End Sub

复制代码

跳转到最佳答案楼层

爱疯 · 发表于 2011-10-28 00:32

建议放在一起，用函数做。最好上传附件，问题更易被解决

爱疯 · 发表于 2011-10-28 00:32

建议放在一起，用函数做。最好上传附件，问题更易被解决

e2solo · 发表于 2011-10-28 07:27

謝謝老師。煩請解答

mxg825 · 发表于 2011-10-28 11:51

这个最佳答案由 mxg825 给出，感谢 mxg825 的回答。

单击隐藏图章

本帖最后由 mxg825 于 2011-10-28 12:01 编辑

Sub 生成数据()
Dim D As New Dictionary, LD As New Dictionary, ID As New Dictionary '字典
Dim Arr1, Arr2, Arr3 '数组
Dim 列&, 行&, L&, R&, X& '行列号变量
Arr1 = Sheets("專長表").Range("a2:B" & Sheets("專長表").Range("a65536").End(xlUp).Row)
Arr2 = Sheets("所屬公司").Range("a2:B" & Sheets("所屬公司").Range("a65536").End(xlUp).Row)
L = 1: R = 1
LD("公司\專長") = L
For X = 1 To UBound(Arr1)
If Not LD.Exists(Arr1(X, 2)) Then
L = L + 1
LD(Arr1(X, 2)) = L
End If
D(Arr1(X, 1)) = LD(Arr1(X, 2))
Next
If L = 1 Then Exit Sub
Arr3 = Application.Transpose(LD.keyS)
For X = 1 To UBound(Arr2)
行 = D(Arr2(X, 2))
If ID.Exists(Arr2(X, 1)) Then
列 = ID(Arr2(X, 1))
Arr3(行, 列) = Arr3(行, 列) + 1
Else
R = R + 1
ID(Arr2(X, 1)) = R
ReDim Preserve Arr3(1 To L, 1 To R)
Arr3(1, R) = Arr2(X, 1)
Arr3(行, R) = 1
End If
Next
Sheets("生成").Cells.Clear
Sheets("生成").Range("A1").Resize(R, L) = Application.Transpose(Arr3)
MsgBox "完成", , "mxg825提示"
End Sub

复制代码

e2solo · 发表于 2011-10-28 12:06

謝謝老師
謝謝老師

爱疯 · 发表于 2011-10-28 12:16

注：手工清除多余字符后，test才有效。
sheets(2)的A7的第2个字符，为什么代码替换不掉呀，等会再去问问

Sub test()
Dim A, B, C, i%, j%, k%, l%
A = Sheets(1).Range("a1:b" & Sheets(1).Range("a65536").End(xlUp).Row)
B = Sheets(2).Range("a1:b" & Sheets(2).Range("a65536").End(xlUp).Row)
C = Sheets(3).Range("a1:d" & Sheets(3).Range("a65536").End(xlUp).Row)
For i = 2 To UBound(C)
      For j = 2 To UBound(C, 2)
         C(i, j) = 0
         For k = 2 To UBound(B) '公司-姓名
            If C(i, 1) = B(k, 1) Then
                  For l = 2 To UBound(A) '姓名-专业
                     If B(k, 2) = A(l, 1) And A(l, 2) = C(1, j) Then
                        C(i, j) = C(i, j) + 1
                     End If
                  Next l
            End If
         Next k
      Next j
Next i
Sheets(3).Cells(1, 1).Resize(UBound(C), UBound(C, 2)) = C
End Sub

		自动登录	找回密码
密码			注册