ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

VBA ­pºâ¼Æ¾Ú¥X²{¦¸¼Æ¨Ã±Æ§Ç

VBA ­pºâ¼Æ¾Ú¥X²{¦¸¼Æ¨Ã±Æ§Ç

¥»©«³Ì«á¥Ñ s13030029 ©ó 2019-8-9 16:34 ½s¿è

Q1¡G½Ð°Ý­n¦p¦ó¤£Åã¥Ü©Î­pºâªÅ¥ÕªºÀx¦s®æ??
Q2¡G½Ð°Ý­n¦p¦ó¤£Åã¥Ü¦¸¼Æ¤p©ó1ªºÀx¦s®æ??

Â^¨ú.JPG
2019-8-9 16:33
  1. Sub «ö¥X²{¦¸¼Æ±Æ§Ç()
  2.     Dim d As Object
  3.     Dim Arr
  4.     Dim i As Integer, j As Integer
  5.     Application.ScreenUpdating = False
  6.     Range("A15:B30").Clear
  7.     '´£¨ú¤£­«½Æ­È¨Ö­pºâ¥X²{¦¸¼Æ
  8.     Set d = CreateObject("Scripting.Dictionary")
  9.     Arr = Range("A2:H6")
  10.     For i = 1 To UBound(Arr, 1) '­pºâ°}¦C¤j¤p(¦C)
  11.         For j = 1 To UBound(Arr, 2) '­pºâ°}¦C¤j¤p(Äæ)
  12.             If Not d.Exists(Arr(i, j)) Then
  13.                 d.Add Arr(i, j), 1
  14.             Else
  15.                 d.Item(Arr(i, j)) = d.Item(Arr(i, j)) + 1
  16.             End If
  17.         Next
  18.     Next
  19.    
  20.     '¿é¥X¨Ã±Æ§Ç
  21.     Range("A15").Resize(d.Count) = Application.Transpose(d.keys)
  22.     Range("B15").Resize(d.Count) = Application.Transpose(d.items)
  23.     Range("A15:B15").Resize(d.Count).Sort key1:=Range("B14"), Order1:=xlDescending
  24.    
  25.     Set d = Nothing
  26.     Application.ScreenUpdating = True
  27. End Sub
½Æ»s¥N½X
test.rar (20.2 KB)

Sub «ö¥X²{¦¸¼Æ±Æ§Ç()
Dim Arr, A, xD, Brr(1 To 20000, 1 To 2), N&
Range("A15:B30").Clear
Arr = Range("A2:H6")
Set xD = CreateObject("Scripting.Dictionary")
For Each A In Arr
    If A = "" Then GoTo 101
    xD(A) = xD(A) + 1
    If xD(A) = 2 Then N = N + 1:  xD(A & "S") = N:  Brr(N, 1) = A
    If xD(A) > 1 Then Brr(xD(A & "S"), 2) = xD(A)
101: Next
With [A15:B15].Resize(N)
     .Value = Brr
     .Sort Key1:=.Item(2), Order1:=xlDescending, _
           Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
End With
End Sub


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

TOP

¦^´_ 2# ­ã´£³¡ªL
¨º¦pªG»¡§Úªº¼Æ¾Ú¥i¯à¨S¦³¥þ³¡¿é¤J§¹¡A¦ý¬O¨Cµ§¥X²{ªº¦¸¼Æ³£¥u¦³¤@¦¸
³o¬qµ{¦¡½X´N·|¥X²{¿ù»~¡A³o­n«ç»ò§ï?
With [G1:H1].Resize(N)
     .Value = Brr
     .Sort Key1:=.Item(2), Order1:=xlDescending, _
           Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
End With

TOP

¦^´_ 3# s13030029

   IF N=0 THEN EXIT SUB '¥[³o¤@¦æ
   With [A15:B15].Resize(N)
     .Value = Brr
     .Sort Key1:=.Item(2), Order1:=xlDescending, _
           Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
   End With

TOP

¦^´_ 4# ­ã´£³¡ªL

­ì¨Ó¦p¦¹~ÁÂÁ­ã¤j~~

TOP

¥»©«³Ì«á¥Ñ s13030029 ©ó 2019-8-14 10:44 ½s¿è

¦^´_ 2# ­ã´£³¡ªL
­ã¤j~
§Ú·Q¦A½Ð°Ý¤@¤U¡A¦pªG­n¦A§ä¥X³Ì¤j­È©M³Ì¤p­È¡A¨Ã¥Î.Interior.Color ¼Ð°O¦¨¬õ¦âªº¸Ü¡A­n«ç»ò§ï???
(¥X²{¦¸¼Æµ¥©ó1ªº³¡¤À¥i¯àÁÙ¬O­nÅã¥Ü¥X¨Ó)
test.rar (27.38 KB)
  1. Sub «ö¥X²{¦¸¼Æ±Æ§Ç()
  2.     Application.ScreenUpdating = False
  3.     Dim Arr, a, xD, Brr(1 To 20000, 1 To 2), N&
  4.     ThisWorkbook.Sheets("¶q´ú").Range("H2:I" & Range("H" & Rows.Count).End(xlDown).Row).Clear
  5.     Arr = Range("B2:F31")
  6.     Set xD = CreateObject("Scripting.Dictionary")
  7.     If ThisWorkbook.Sheets("¶q´ú").[B2] = "" Then Exit Sub
  8.     For Each a In Arr
  9.         If a = "" Then GoTo 101
  10.         xD(a) = xD(a) + 1
  11.         If xD(a) = 1 Then N = N + 1:  xD(a & "S") = N:  Brr(N, 1) = a
  12.         If xD(a) > 1 Then Brr(xD(a & "S"), 2) = xD(a)
  13. 101:     Next
  14.     If N = 0 Then Exit Sub
  15.     With ThisWorkbook.Sheets("¶q´ú").[H2:I2].Resize(N)
  16.          .Value = Brr
  17.          .Sort Key1:=.Item(2), Order1:=xlDescending, _
  18.                Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
  19.     End With

  20.     With ThisWorkbook.Sheets("¶q´ú").Range("H1:I" & Range("H" & Rows.Count).End(xlUp).Row)
  21.          .NumberFormatLocal = "0.00_ "
  22.         .HorizontalAlignment = xlCenter
  23.         .VerticalAlignment = xlCenter
  24.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  25.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  26.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  27.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  28.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  29.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  30.     End With
  31.     With ThisWorkbook.Sheets("¶q´ú").Range("I1:I11")
  32.         .NumberFormatLocal = "0"
  33.     End With
  34.     For x = 2 To 6
  35.     For Y = 2 To 31
  36.         Cells(Y, x).Interior.Color = xlNone
  37.         If Cells(Y, x).Value = Cells(2, "H").Value And Cells(2, "H") <> "" Then
  38.             Cells(Y, x).Interior.Color = RGB(252, 216, 162)
  39.             Cells(2, "H").Interior.Color = RGB(252, 216, 162)
  40.         End If
  41.         If Cells(Y, x).Value = Cells(3, "H").Value And Cells(3, "H") <> "" Then
  42.             Cells(Y, x).Interior.Color = RGB(144, 248, 169)
  43.             Cells(3, "H").Interior.Color = RGB(144, 248, 169)
  44.         End If
  45.         If Cells(Y, x).Value = Cells(4, "H").Value And Cells(4, "H") <> "" Then
  46.             Cells(Y, x).Interior.Color = RGB(170, 250, 252)
  47.             Cells(4, "H").Interior.Color = RGB(170, 250, 252)
  48.         End If
  49.     Next Y
  50.     Next x
  51.     Application.ScreenUpdating = True
  52. End Sub
  53. '=================================
  54. Sub ²M°£()
  55.     ThisWorkbook.Sheets("¶q´ú").Range("B2:F31").ClearContents
  56.     With ThisWorkbook.Sheets("¶q´ú").Range("B2:F31")
  57.         .NumberFormatLocal = "0.00_ "
  58.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  59.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  60.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  61.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  62.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  63.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  64.         .Interior.Color = xlNone
  65.     End With
  66.     Range("B2").Select
  67. End Sub
½Æ»s¥N½X

TOP

ÀH·NºÛ "EXCEL°g"  blog  ©Îhttps://hcm19522.blogspot.com/ EXCEL¨ç¼Æ

TOP

        ÀR«ä¦Û¦b : µÊ®ð¼L¤Ú¤£¦n¡A¤ß¦a¦A¦n¤]¤£¯àºâ¬O¦n¤H¡C
ªð¦^¦Cªí ¤W¤@¥DÃD