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

[µo°Ý] §ä¥X­«Âиê®Æ

[µo°Ý] §ä¥X­«Âиê®Æ

¦U¦ì¤j¤j,
§Ú¥Î¦³­­ªº¯à¤O¼g¤F¤@­Ó"§ä¥X­«Âиê®Æªºµ{¦¡¡¨, ¦ý§Ú¦³¤@¨Ç°ÝÃD§Ú¥¼¯à¸Ñ¨M,½Ð¦U¦ìÀ°¦£

1.        ¦bHÄæ,¥uÅã¥Ü­«ÂЪºÀx¦s®æ¦ì¸m,¦Ó¤£ÅV¥Ü¥»¨­ªºÀx¦s®æ¦ì¸m
2.        ¦b­«ÂЪº±¡ªp¤U, ¤ñ¦pF2®æ¦³¡¨Y¡¨ªº¦r,¦p¦ó§ä¥X­«ÂЪºÀx¦s®æD86³£¥i¥H¦³¦P¼Ëªº¤å¦r©O?
3.        ¦b¶W¹L2­Ó­«ÂЪº±¡ªp¤U,J Äæ¥i¥H¦h­«Åã¥ÜAÄ檺¦WºÙ,

ÁÂÁÂ

Book1.rar (31.6 KB)

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

TOP

¦^´_ 2# hcm19522


    ÁÂÁ§Aªº¦^ÂСA¦ý¥i¤£¥i¥H¥ÎVBA¸Ñ¨M§Ú©Ò¦³ªº°ÝÃD¡AÁÂÁÂ

TOP

¥»©«³Ì«á¥Ñ °a¤ªºµ ©ó 2021-3-5 03:23 ½s¿è

¦^´_ 3# mdr0465

¦³ªÅÀ°§Ú¸Õ¸Õ¬Ý¡@¬O¤£¬O§A­nªºµ²ªG¡@·PÁ¡@¡@¦³¤@­Ó°ÝÃD¡@´N¬O¸ê®Æ¤Ó¦h¡@·|µ¥«Ü¤[¡D¡D¡D¦]¬°°j°é¤Ó¦h¤F¦Ó¥B¬Oª½±µ¿é¤J¨ìÀx¦s®æ¡@¬Ý¬Ý¦³¨S¦³¤j¤j¥i¥HÀ°¦£¡@¡@

0305.rar (22.53 KB)

TOP

¦^´_ 4# °a¤ªºµ


    °a¤ªºµ®v¥S
«Ü·PÁ§AªºÀ°¦£,¬°¤F§ó°t¦X§Úªº»Ý­n,¦ý·í¤¤¦³¨Ç¦a¤è,§Ú¹Á¸Õ¦Û¦æ­×§ïµ{¦¡,¦ý©l²×¥\¤O¦³­­,§Ú³£¥¢±Ñ¤F,·Q¦A¦¸¦V§A«ü±Ð
 
1.      ¦pªG¦bAÄ檺¤å¦r¤£¬O¥þ³¡¤@¼Ë, ·í¦bDÄæ§ä¥X¦³¬Û¦Pªº®É­Ô, IÄ檺Àx¦s®æ¯à§_°µ¨ì¥þ³¡Åã¥Ü¥XAÄæ¬Û¹ïÀ³ªºÀx¦s®æ¤å¦r? ¤ñ¨Ò(HÄæ¬OD6,D4, ¬Û¹ïÀ³¬OIÄæ¬OA,B)
 
2.      ¦Ó·íDÄæ§ä¥X¬Û¦Pªº®É­Ô, FÄæ¬ÛªºÀx¦s®æ¬O¦³¡¨Y¡¨¦rªº®É­Ô, ©Ò¦³¬Û¦PªºÀx¦s®æ³£·|¦P¼ËÅã¥Ü¤@¼Ëªº¤å¦r,
 
¸U¤À·PÁ§A

TOP

¦^´_ 5# mdr0465

¤£¤Ó¯à²z¸Ñ±z©Ò´y­zªº°ÝÃD¡A¥i§_½Ð±zª½±µ±N¹ê»Úªº»Ý¨Dªþ¤W¸Ñµª¦ÓªþÀɤW¨Ó
¸ê®Æ¤ñ¼Æ¥i¥H¤Ö¤@ÂI
ÁÂÁÂ

TOP

¦^´_ 6# samwang


  SAMWANG ÁÂÁ§AÀ°¦£, ¬O§Úªí¹F¯à¤O¤£¦n,
½Ð¬Ýªþ¹Ï,§Æ±æ§A·|©ú¥Õ§Úªº·N«ä¡AÁÂÁÂ
mmexport1614934519977.png

TOP

¦^´_ 7# mdr0465
  1. Sub test()

  2.     Dim D As Object, R, x, k

  3.     Application.ScreenUpdating = False
  4.     [A2:A10000].EntireRow.Interior.ColorIndex = xlNone
  5.     [H2:J10000].Clear

  6.     Set D = CreateObject("Scripting.Dictionary")
  7.     For Each R In Range("D1").CurrentRegion.Columns(4).Cells
  8.         R.Interior.ColorIndex = xlNone
  9.         If Not D.Exists(R.Value) Then
  10.             Set D(R.Value) = R
  11.         Else
  12.             Set D(R.Value) = Union(D(R.Value), R)
  13.         End If
  14.     Next
  15.     [H1] = "¹q¸Ü­«ÂÐÀx¦s®æ¦ì¸m"
  16.     [I1] = "¹ïÀ³³õªº¦WºÙ"
  17.     For Each R In D.KEYS
  18.         If D(R).Cells.Count > 1 Then
  19.             D(R).EntireRow.Interior.ColorIndex = 6
  20.             For Each x In D(R)
  21.                 x¦ì¸m = ""
  22.                 x³õ¦a = ""
  23.                 For Each k In D(R)
  24.                     If x.Address <> k.Address Then
  25.                         x¦ì¸m = x¦ì¸m & "," & k.Address(0, 0)
  26.                         x³õ¦a = x³õ¦a & "," & k.Offset(0, -3)
  27.                     End If
  28.                 Next
  29.                 x.Offset(0, 4) = Mid(x¦ì¸m, 2, 99)
  30.                 x.Offset(0, 5) = Mid(x³õ¦a, 2, 99)
  31.             Next
  32.         End If
  33.     Next
  34.     Application.ScreenUpdating = True
  35. End Sub
½Æ»s¥N½X
{...} ªí¥Ü»Ý­n¥Î CTRL+SHIFT+ENTER ¤TÁä¿é¤J¤½¦¡

TOP

¥»©«³Ì«á¥Ñ °a¤ªºµ ©ó 2021-3-5 22:04 ½s¿è

¦^´_ 7# mdr0465

«Øij§A¥Î  ML089ª©¤j ªº­×§ï ­è¤~´ú¸Õ ¸ê®Æ¹L¦hªº¸Ü ¤£·|¤ÓºC...¦Ó¥BÅÞ¿è«Ü²M·¡
  1. Sub test()

  2.     Dim D As Object, R, x, k

  3.     Application.ScreenUpdating = False
  4.     [A2:A10000].EntireRow.Interior.ColorIndex = xlNone
  5.     [H2:J10000].Clear

  6.     Set D = CreateObject("Scripting.Dictionary")
  7.     For Each R In Range("D1").CurrentRegion.Columns(4).Cells
  8.         R.Interior.ColorIndex = xlNone
  9.         If Not D.Exists(R.Value) Then
  10.             Set D(R.Value) = R
  11.         Else
  12.             Set D(R.Value) = Union(D(R.Value), R)
  13.         End If
  14.     Next
  15.     [H1] = "¹q¸Ü­«ÂÐÀx¦s®æ¦ì¸m"
  16.     [I1] = "¹ïÀ³³õªº¦WºÙ"
  17.     For Each R In D.KEYS
  18.         If D(R).Cells.Count > 1 Then
  19.             D(R).EntireRow.Interior.ColorIndex = 6
  20.             For Each x In D(R)
  21.                 x¦ì¸m = ""
  22.                 x³õ¦a = ""
  23.                 For Each k In D(R)
  24.                     If x.Address <> k.Address Then
  25.                         x¦ì¸m = x¦ì¸m & "," & k.Address(0, 0)
  26.                         x³õ¦a = x³õ¦a & "," & k.Offset(0, -3)
  27.                     End If
  28.                 Next

  29.                 x.Offset(0, 2) = "Y"

  30.                 x.Offset(0, 4) = Mid(x¦ì¸m, 2, 99)
  31.                 x.Offset(0, 5) = Mid(x³õ¦a, 2, 99)
  32.             Next
  33.         End If
  34.     Next
  35.     Application.ScreenUpdating = True
  36. End Sub
½Æ»s¥N½X

TOP

¦^´_ 7# mdr0465


½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁ¡C

Sub test()
Dim xD, Arr, Brr(), i&, Ar, a&, b$, j%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([F1], [a65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 4)
For i = 1 To UBound(Arr)
    If xD.Exists(Arr(i, 4) & "") Then
        m = m + 1
        ¦C = xD(Arr(i, 4) & "")
        Brr(¦C, 3) = Brr(¦C, 3) & "_" & m
        Brr(¦C, 4) = Brr(¦C, 4) & "_" & Arr(i, 1)
    Else
        m = m + 1
        xD(Arr(i, 4) & "") = i
        Brr(m, 2) = Arr(i, 4)
        Brr(m, 3) = m
        Brr(m, 4) = Arr(i, 1)
    End If
Next

For i = 1 To UBound(Arr)
    For ib = 1 To UBound(Brr)
        pos = InStr(Brr(ib, 3), "_")
        If pos > 0 And Arr(i, 4) = Brr(ib, 2) Then
            Ar = Split(Brr(ib, 3), "_")
            For j = 0 To UBound(Ar)
                a = Split(Brr(ib, 3), "_")(j)
                b = Split(Brr(ib, 4), "_")(j)
                If i <> a Then
                    If Cells(i, 8) = "" Then
                        Cells(i, 8) = "D" & a
                        Cells(i, 9) = b
                        Rows(i).EntireRow.Interior.ColorIndex = 6
                    Else
                        Cells(i, 8) = Cells(i, 8) & "," & "D" & a
                        Cells(i, 9) = Cells(i, 9) & "," & b
                    End If
                End If
            Next
        End If
    Next
Next
End Sub

TOP

        ÀR«ä¦Û¦b : ¯¸¦b¥b¸ô¡A¤ñ¨«¨ì¥Ø¼Ð§ó¨¯­W¡C
ªð¦^¦Cªí ¤W¤@¥DÃD