ªð¦^¦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®æ??

  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

google"EXCEL°g"  blog  ©Îgoogleºô§}:https://hcm19522.blogspot.com/

TOP

³o¬O§Ú°µ¥X¨Óªºµ²ªGµ¹¤j®a°Ñ¦Ò~~~
  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) = 2 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.     '±Æ§Ç
  15.     If N = 0 Then Exit Sub
  16.     With ThisWorkbook.Sheets("¶q´ú").[H2:I2].Resize(N)
  17.          .Value = Brr
  18.          .Sort Key1:=.Item(2), Order1:=xlDescending, _
  19.                Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
  20.     End With
  21.     'Àx¦s®æ¸m¤¤¡B®æ½u¡B¤p¼ÆÂI
  22.     With ThisWorkbook.Sheets("¶q´ú").Range("H1:I" & Range("H" & Rows.Count).End(xlUp).Row)
  23.          .NumberFormatLocal = "0.00_ "
  24.         .HorizontalAlignment = xlCenter
  25.         .VerticalAlignment = xlCenter
  26.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  27.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  28.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  29.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  30.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  31.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  32.     End With
  33.     With ThisWorkbook.Sheets("¶q´ú").Range("I1:I11")
  34.         .NumberFormatLocal = "0"
  35.     End With
  36.     '§ä³Ì¤j­È¡B³Ì¤p­È
  37.     With ThisWorkbook.Sheets("¶q´ú").Range("K1:L2")
  38.          [k1].Value = "³Ì¤j­È": [L1].Value = "³Ì¤p­È"
  39.          Range("K1:L1").Font.Bold = True
  40.          Range("K1:L1").Name = "·s²Ó©úÅé"
  41.         .Font.Size = 12
  42.         Range("K1:L1").Interior.Color = RGB(217, 226, 243)
  43.         .HorizontalAlignment = xlCenter
  44.         .VerticalAlignment = xlCenter
  45.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  46.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  47.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  48.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  49.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  50.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  51.     End With
  52.     [k2] = Application.Max(Arr)
  53.     [L2] = Application.Min(Arr)
  54.     '§ä¹ïÀ³ªº­È¡A¨Ã¶ñº¡ÃC¦â
  55.     For x = 2 To 6
  56.     For Y = 2 To 31
  57.         Cells(Y, x).Interior.Color = xlNone
  58.         If Cells(Y, x).Value = [H2].Value And [H2] <> "" Then
  59.             Cells(Y, x).Interior.Color = RGB(252, 216, 162)
  60.             [H2].Interior.Color = RGB(252, 216, 162)
  61.         End If
  62.         If Cells(Y, x).Value = [H3].Value And [H3] <> "" Then
  63.             Cells(Y, x).Interior.Color = RGB(144, 248, 169)
  64.             [H3].Interior.Color = RGB(144, 248, 169)
  65.         End If
  66.         If Cells(Y, x).Value = [H4].Value And [H4] <> "" Then
  67.             Cells(Y, x).Interior.Color = RGB(170, 250, 252)
  68.             [H4].Interior.Color = RGB(170, 250, 252)
  69.         End If
  70.         If Cells(Y, x).Value = [k2].Value Then
  71.             Cells(Y, x).Font.Color = RGB(0, 0, 255)
  72.             [k2].Font.Color = RGB(0, 0, 255)
  73.             Cells(Y, x).Font.Bold = True
  74.         End If
  75.         If Cells(Y, x).Value = [L2].Value Then
  76.             Cells(Y, x).Font.Color = RGB(255, 0, 0)
  77.             [L2].Font.Color = RGB(255, 0, 0)
  78.             Cells(Y, x).Font.Bold = True
  79.         End If
  80.     Next Y
  81.     Next x
  82.     '³]©wÄæ¼e
  83.     Columns("A:L").ColumnWidth = 8
  84.     Columns("G").ColumnWidth = 3
  85.     Columns("J").ColumnWidth = 3
  86. End Sub
  87. '=================================
  88. Sub ²M°£()
  89.     ThisWorkbook.Sheets("¶q´ú").Range("B2:F31").ClearContents
  90.     With ThisWorkbook.Sheets("¶q´ú").Range("B2:F31")
  91.         .NumberFormatLocal = "0.00_ "
  92.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  93.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  94.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  95.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  96.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  97.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  98.         .Interior.Color = xlNone
  99.         .Font.Bold = False
  100.         .Font.Color = RGB(0, 0, 0)
  101.     End With
  102.     Range("B2").Select
  103. End Sub
½Æ»s¥N½X

TOP

        ÀR«ä¦Û¦b : ¨Ã«D¦³¿ú¾{¬O§Ö¼Ö¡A°Ý¤ßµL·\¤ß³Ì¦w¡C
ªð¦^¦Cªí ¤W¤@¥DÃD