[µo°Ý] ¦h±ø¥ó²Î­p

b9208

±z¦n¡I
½Ð°Ý¦h±ø¥ó²Î­p¦¸¼Æ
¥Ñ¡u¸ê®Æ¡v¤u§@ªí²Î­p¨C¤é¡]BÄæ¡^¦U¤H¤f¡]HÄæ¡^¨Ï¥Î¦¸¼Æ¡A¨Ã¿é¥X©ó¡u¤u§@ªí2¡v¡C
ÁÂÁÂ
W1.zip (19.49 KB)

¤U¸ü¦¸¼Æ: 20

2020-8-20 16:11

singo1232001

1. Sub t5()
   
2. i = Split("Provider=Microsoft.,Jet.OLEDB.4,.0;Extended Properties=Excel ,8,.0;Data Source=", ",")
   
3. If Application.Version > 12 Then i(1) = "ACE.OLEDB.12": i(3) = 12
   
4. Set cn = CreateObject("adodb.connection"): cn.Open Join(i, "") & ThisWorkbook.FullName
   
5. Set S1 = Sheet1: Set s2 = Sheet2: S1.[B7:AA9999].ClearContents:
   
6. f = " from [¸ê®Æ$B4:I] "
   
7. S1.[B7].CopyFromRecordset cn.Execute("select distinct ¤é´Á,¬P´Á " & f)
   
8. S1.[P7].CopyFromRecordset cn.Execute("select distinct ¤é´Á,¬P´Á " & f)
   
9. p = Split("select b.c from [¤u§@ªí2$B6:B] as a left join (;;) as b on a.¤é´Á=b.¤é´Á ", ";")
   
10. For Each Z In S1.[d6:L6]
    
11. p(1) = "select ¤é´Á,¬P´Á,count(¤J¤f) as c " & f & " where ¤J¤f = '" & Z.Value & "' group by ¤é´Á,¬P´Á,¤J¤f"
    
12. Z.Offset(1, 0).CopyFromRecordset cn.Execute(Join(p, ""))
    
13. x = x & "+ iif(IsNull(" & Z.Value & "),0," & Z.Value & ") "
    
14. Next
    
15. S1.[M7].CopyFromRecordset cn.Execute("select " & Mid(x, 2, 9999) & " from [¤u§@ªí2$D6:L]")
    
16. 
    
17. For Each Z In S1.[R6:Z6]
    
18. p(1) = "select ¤é´Á,¬P´Á,count(¥X¤f) as c " & f & " where ¥X¤f = '" & Z.Value & "' group by ¤é´Á,¬P´Á,¥X¤f"
    
19. Z.Offset(1, 0).CopyFromRecordset cn.Execute(Join(p, ""))
    
20. Next
    
21. S1.[AA7].CopyFromRecordset cn.Execute("select " & Mid(x, 2, 9999) & " from [¤u§@ªí2$R6:Z]")
    
22. End Sub

½Æ»s¥N½X

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C.¦r¨å»P¾î¦VÁa¦V±Æ§Ç...,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð
¸ê®Æªí:

¤U¸ü (105.28 KB)

2023-12-4 15:54

µ²ªGªí°õ¦æ«e:

¤U¸ü (61.83 KB)

2023-12-4 15:54

°õ¦æ«áªºµ²ªGªí:

¤U¸ü (121.57 KB)

2023-12-4 15:55

Option Explicit
Sub TEST_A()
Dim Brr, Crr(2000, 100), v, Z, Q, i&, j%, R&, C%, N&, U%, T2$, T8$
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range(Sheet2.[H1], Sheet2.[B65536].End(3)(1, 0))
For i = 5 To UBound(Brr)
   T2 = Trim(Brr(i, 2)): T8 = Trim(Brr(i, 8))
   If T2 = "" Or T8 = "" Then GoTo i01
   R = Z(T2): C = Z(T8): Crr(0, 0) = "¤é´Á"
   If R = 0 Then N = N + 1: R = N: Z(T2) = R: Crr(R, 0) = T2
   If C = 0 Then U = U + 1: C = U: Z(T8) = C: Crr(0, C) = T8
   Crr(R, C) = Crr(R, C) + 1
i01: Next
Sheet1.[B6:B2000].EntireRow.Delete
With Sheet1.[B6].Resize(N + 1, U + 2)
   .Value = Crr
   .Offset(0, 1).Sort KEY1:=.Item(1, 2), Order1:=1, Header:=0, Orientation:=2
   .Offset(1, 0).Sort KEY1:=.Item(2, 1), Order1:=1, Header:=0, Orientation:=1
   .Item(1)(2, U + 2).Resize(N, 1) = "=SUM(" & Range(.Cells(2, 2), .Cells(2, U + 1)).Address(0, 0) & ")"
   .Cells(1, U + 2) = "Total"
   .Borders.LineStyle = 1
End With
End Sub

­ã´£³¡ªL

¦^´_ 19# b9208

¥[¤Fµù¸Ñ, ºCºC¬Ý:
Xl0000235.rar (20.83 KB)

¤U¸ü¦¸¼Æ: 14

2020-8-26 11:05

¦]¦Ò¼{[¤J¤f/¥X¤f]ªº¤é´Á¸ê®Æ¥i¯à¤£¤@­P,
¨Ò¦p:7/1..¤J¤f¦³¸ê®Æ, ¥X¤f¨S¸ê®Æ, ¨º¨âªíªº¦C¼Æ´N¤£¬Û¦P,
©Ò¥HÁÙ¬O¨âªí¤À§O§PÂ_~~

b9208

¦^´_ 15# ­ã´£³¡ªL
­ã¤j
Àµ½Ð¨ó§U©ó¤u§@ªí2¤º¼W¥[¿é¥X¡u¬P´Á¡vÄæ¦ì¡A«D±`·PÁ¡C
   Q3.rar (29.4 KB)

¤U¸ü¦¸¼Æ: 1

2020-8-25 21:30

b9208

¦^´_ 17# n7822123
Às¤j
«D±`©êºp¡A¿é¥X³¡¤À¦A¼W¥[¡u¬P´Á¡vÄæ¦ì¡]¦pªþ¥ó¡^¡C
¦³¸Õ³o¦Û¤v­×­q¡A¦ý¬O¨S¦³¦¨¥\¡A¥\¤O¤£¨¬¡C
ÁÂÁÂ
W2-0824.rar (28.88 KB)

¤U¸ü¦¸¼Æ: 0

2020-8-24 20:22

n7822123

¦^´_ 16# b9208 '

¦]¬°³o¬OCtrl+A (CurrentRegion)ªº®ÄªG......­ì¨Ó²Ä3¦C¤£¤@©w·|¬OªÅ¥Õªü

­×§ïArr§ì¨ú¸ê®Æ½d³ò´N¥i¥H¤F

µ{¦¡¦p¤U

Sub ²Î­p¤J¤f()
[B6].CurrentRegion.Offset(2).Clear
²Î­p [B6], 8
End Sub
Sub ²Î­p¥X¤f()
[P6].CurrentRegion.Offset(2).Clear
²Î­p [P6], 9
End Sub
Sub ²Î­p(ByVal cel0 As Range, Ci As Long)
Dim D, Arr, Brr, T$, K1$, K2$, Key, R&, Ro&, Co&, Rg As Range
Set D = CreateObject("Scripting.Dictionary")
Arr = [¸ê®Æ!A4].Resize([¸ê®Æ!B4].End(4).Row - 3, 9)
For R = 2 To UBound(Arr)
  K1 = Arr(R, 2): K2 = Arr(R, Ci)
  If K1 <> T Then Ro = Ro + 1: D(K1) = Ro: T = K1
  If K2 <> "" Then Key = K1 & "-" & K2: D(Key) = D(Key) + 1
Next
ReDim Brr(1 To Ro, 1 To 11)
For Each Key In D.keys
  If InStr(Key, "-") = 0 Then Brr(D(Key), 1) = Key: GoTo ¤U­ÓKey
  Ro = D(Split(Key, "-")(0))
  Set Rg = cel0.Resize(, 10).Find(Split(Key, "-")(1), , , xlWhole)
  If Not Rg Is Nothing Then
    Co = Rg.Column - cel0.Column + 1
    Brr(Ro, Co) = D(Key): Brr(Ro, 11) = Brr(Ro, 11) + D(Key)
  End If
¤U­ÓKey: Next
With cel0(2).Resize(Ro, 11)
  .Value = Brr: .Borders.LineStyle = 1
  .VerticalAlignment = xlBottom
  .HorizontalAlignment = xlCenter
End With
End Sub

b9208

¦^´_ 11# n7822123
Às¤j
¡u¸ê®Æ¡v¤u§@ªíB2, B3Àx¦s®æ¦pªG«DªÅ®æ¡A«h¿é¥X®É¡A·|¦b¼ÐÃD¤U¼W¥[¤G¦æ¡C¡]¦pªþ¥ó¡^
W2-0823.rar (28.66 KB)

¤U¸ü¦¸¼Æ: 6

2020-8-23 12:45

­ã´£³¡ªL

Sub TEST_T2()
Dim Arr, Brr, xD, i&, j%, K, R&, C&, N&(1)
Set xD = CreateObject("Scripting.Dictionary")
[¤u§@ªí2!B7:B2000].EntireRow.Delete
Arr = [¤u§@ªí2!B6:K6]
For i = 2 To UBound(Arr, 2): xD(Arr(1, i) & "") = i: Next
Arr = Range([¸ê®Æ!A1], Sheets("¸ê®Æ").UsedRange)
ReDim Brr(1 To UBound(Arr), 1 To 11):  xD(0) = Brr:  xD(1) = Brr
For i = 5 To UBound(Arr)
    K = Arr(i, 2): If K = "" Then GoTo i01
    For j = 0 To 1
        R = xD(K & j): C = xD(Arr(i, 8 + j) & ""): Brr = xD(j)
        If C = 0 Then GoTo j01
        If R = 0 Then N(j) = N(j) + 1: R = N(j): xD(K & j) = R: Brr(R, 1) = K
        Brr(R, C) = Brr(R, C) + 1: Brr(R, 11) = Brr(R, 11) + 1
        xD(j) = Brr
j01: Next j
i01: Next i
For j = 0 To 1
    With Sheets("¤u§@ªí2").Range(Array("B7", "P7")(j)).Resize(N(j), 11)
         .Value = xD(j)
         .Borders.LineStyle = 1
    End With
Next j
End Sub

°µ­Ó¤p°j°é, ¦³ÂI¶~~


=======================================

b9208

¦^´_ 12# ­ã´£³¡ªL
­ã¤j
«D±`·PÁÂ
¤À¶}¼g¤ñ¸û²M·¡¤Î®e©ö¾\Ū