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

[µo°Ý] ¼Æ¦r¦U¨ú1

¥»©«³Ì«á¥Ñ ziv976688 ©ó 2021-7-19 07:02 ½s¿è

¦^´_ 5# ML089
¤£¦n·N«ä¡A§Ú±N¤½¦¡®M¥Î¦bVBA»yªk¤¤~²£¥Í°»¿ù¡C
¥u¬OFREQUENCY©MTRIM©MSUBSTITUTEµ¥¨ç¼Æ¹ï§Ú¨Ó»¡~¤Ó²`¶ø¤F~
®£©È¬O§Ú±N­ì5Äæ39­Ó¸¹½Xªº¶Q¸Ñ¡A®M¥Î¦b7Äæ49­Ó¸¹½X¤½¦¡®É¦³§ï¿ù¤F!¡H
·Ð½Ð±zÀ°§ÚÀ˵ø¤@¤U~ ¦n¶Ü ?
©ÎªÌ½Ð±zª½±µ¥Hµ{¦¡»yªk¸ÑÃD(¦³¬Ý¹L±z¸Ñ¹Lµ{¦¡ÃD )¡C
ÁÂÁ±z
¼Æ¦r¦U¨ú1(Àx¦s®æ¦³,°Ï¹j²Å¸¹)_VBA.rar (96.34 KB)

TOP

¦^´_ 11# ziv976688

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

Private Sub CommandButton1_Click()
Dim Arr, xD, s%, Tm, a%, i&, j&
Set xD = CreateObject("Scripting.Dictionary")
Tm = Timer
Application.ScreenUpdating = False '¦b­I´º¤U°õ¦æ
   For s = 1 To 6   '6­Ó¤u§@ªí
        Shrr = Array("·Ç2¶i3", "·Ç3¶i4", "·Ç4¶i5", "·Ç5¶i6", "·Ç6¶i7", "·Ç7¶i8")
        With Sheets(Shrr(s - 1))
            Arr = .Range("d1:j" & .[b65536].End(3).Row)
            For i = 2 To UBound(Arr)
                For j = 1 To UBound(Arr, 2)
                    If Arr(i, j) <> "" Then
                        If InStr(Arr(i, j), ",") Then
                            For w = 0 To UBound(Split(Arr(i, j), ","))
                            a = Split(Arr(i, j), ",")(w): xD(a) = ""
                            Next
                        Else
                            xD(Arr(i, j)) = ""
                        End If
                    End If
                Next
            Next
            If xD.Count > 0 Then
                For i = 1 To xD.Count: Arr(i, 1) = Application.Small(xD.keys, i): Next
                With .Range("a4").Resize(xD.Count, 1)
                    .NumberFormatLocal = "00": .Value = Arr
                End With
                .[a2] = xD.Count & "­Ó": Erase Arr: xD.RemoveAll
            End If
        End With
   Next
MsgBox Timer - Tm
End Sub

TOP

¦^´_ 12# samwang
´ú¸Õ¦¨¥\ !
°õ¦æ®Ä²vÀu¤Æ³\¦h~¥u¥i±¤¡A§Ú¤@ª½·d¤£À´Arr©MBrr­n«ç»ò³]¥ß½d³ò©M¹Bºâ?
©Ò¥H¹J¨ì¦h­ÓSheet(s)ªº½d³ò­n¹Bºâ´N¤@Äw²ö®i
·PÁ±z¤@¦AªºÀ°¦£~·P®¦

TOP

¦^´_ 11# ziv976688

¤£¬O«Ü·|¼gVBA¡A´ê¤@­Óµ¹§A°Ñ¦Ò

Private Sub CommandButton1_Click()
    Set xD = CreateObject("Scripting.Dictionary")
    Tm = Timer
    Application.ScreenUpdating = False    '¦b­I´º¤U°õ¦æ
    Shrr = Array("·Ç2¶i3", "·Ç3¶i4", "·Ç4¶i5", "·Ç5¶i6", "·Ç6¶i7", "·Ç7¶i8")
    For s = 1 To 6   '6­Ó¤u§@ªí
        With Sheets(Shrr(s - 1))
            xRows = .[b65536].End(3).Row '¸ê®Æ³Ì«á¤@¦æ¦ì¸m
            .range("A2:A" & xRows).ClearContents '²M°£¸ê®Æ
            Arr = .range("D1:J" & xRows) '¸ê®ÆÂà°}¦C¡AJOIN·|§Ö3­¿ 0.023 -> 0.0078
            xJoin = ""
            For Each x In Arr: xJoin = xJoin & IIf(x <> "", x & ",", ""): Next '¦X¨ÖD:J¦r¦ê
            For Each xS In Split(xJoin, ","): xD(xS) = "": Next    '²Õ¦r¨å
            If xD.Count > 0 Then
                .[A4].Resize(xD.Count, 1) = Application.Transpose(xD.keys)    '¦r¨å¨ú°ß¤@¡B¤ô¥­Âà««ª½¡B¶ñ¤JÀx¦s®æ
                .[A4].Resize(xD.Count, 1).Sort Key1:=.[A4], Order1:=xlAscending, Header:=xlNo    'Àx¦s®æ±Æ§Ç
                .[A2] = xD.Count & "­Ó": .[A3] = "¸¹½X"
                Erase Arr: xD.RemoveAll
            End If
        End With
    Next
    MsgBox Timer - Tm
End Sub
{...} ªí¥Ü»Ý­n¥Î CTRL+SHIFT+ENTER ¤TÁä¿é¤J¤½¦¡

TOP

Sub TEST()
Dim Brr(1 To 99, 0), xS As Worksheet, A, B
For Each xS In Sheets(Array("·Ç2¶i3", "·Ç3¶i4", "·Ç4¶i5", "·Ç5¶i6", "·Ç6¶i7", "·Ç7¶i8"))
    For Each A In xS.Range("d2:j" & xS.[b65536].End(xlUp).Row + 1).Value
        For Each B In Split(A, ",")
           Brr(B, 0) = B
        Next B
    Next
    With xS.[a4].Resize(99)
         .Value = Brr:  Erase Brr
         .Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
    End With
Next
End Sub

TOP

¥»©«³Ì«á¥Ñ ziv976688 ©ó 2021-7-20 12:41 ½s¿è

¦^´_ 14# ML089
¤Ö¤F¨ú1~~
¦³ªþ¤Wµù©ú~À°§U§Ú¯à¤ñ¸û©úÁA¡C
·PÁª©¥Dªº«ü¾É

TOP

¦^´_ 15# ­ã´£³¡ªL
´ú¸Õ¦¨¥\
·PÁª©¥Dªº«ü¾É

TOP

¥»©«³Ì«á¥Ñ ziv976688 ©ó 2021-7-20 13:21 ½s¿è

¦^´_ 14# ML089
¤£¦n·N«ä¡A¨S¦³ª`·N¨ì´ú¸Õªþ¥ó¥¼¤W¶Ç
¼Æ¦r¦U¨ú1_ML089.rar (89.83 KB)

¦³¬Ý¨ì¦C17
.[A4].Resize(xD.Count, 1) = Application.Transpose(xD.keys)    '¦r¨å¨ú°ß¤@¡B¤ô¥­Âà««ª½¡B¶ñ¤JÀx¦s®æ
¥i¬O¤£ª¾¹D«ç»ò­×¥¿
ÁÂÁ±z

TOP

¥»©«³Ì«á¥Ñ ziv976688 ©ó 2021-7-20 14:04 ½s¿è

¦^´_ 15# ­ã´£³¡ªL
¤£¦n·N«ä¡AÁöµM¯à¥H§Oªº¤èªk¸Ñ¨M¡A¦ý«Ü·Q¬ã²ß±zªº»yªk~
½Ð°Ý  :
A2=COUNT(A4:A52)&"­Ó"       '¥u­n²Î­p49®æ¡A¦]¬°³Ì¦h¤]¥u¦³49­Ó¸¹½X
¥H±zªº»yªk¡AÀ³¸Ó«ç»ò½s¼g ?
ÁÂÁ±z

TOP

¦^´_ 18# ziv976688

­×¥¿µ{¦¡ 02 »P 2 ·|­«½Æ
Private Sub CommandButton1_Click()
    Dim s%, Tm
    Tm = Timer
    Set xD = CreateObject("Scripting.Dictionary")
    Tm = Timer
    Application.ScreenUpdating = False    '¦b­I´º¤U°õ¦æ
    Shrr = Array("·Ç2¶i3", "·Ç3¶i4", "·Ç4¶i5", "·Ç5¶i6", "·Ç6¶i7", "·Ç7¶i8")
    For s = 1 To 6   '6­Ó¤u§@ªí
        With Sheets(Shrr(s - 1))
            xRows = .[b65536].End(3).Row    '¸ê®Æ³Ì«á¤@¦æ¦ì¸m
            .Range("A2:A" & xRows).ClearContents    '²M°£¸ê®Æ
            arr = .Range("D2:J" & xRows)    '¸ê®ÆÂà°}¦C¡AJOIN·|§Ö3­¿ 0.023 -> 0.0078
            'xJoin = ""
            For Each x In arr: xJoin = xJoin & IIf(x <> "", x & ",", ""): Next    '¦X¨ÖD:J¦r¦ê
            For Each xS In Split(xJoin, ",")
                If Val(xS) > 0 Then xD(Val(xS)) = "" '²Õ¦r¨å
            Next
            If xD.Count > 0 Then
                .[A4].Resize(xD.Count, 1) = Application.Transpose(xD.keys)    '¦r¨å¨ú°ß¤@¡B¤ô¥­Âà««ª½¡B¶ñ¤JÀx¦s®æ
                .[A4].Resize(xD.Count, 1).Sort Key1:=.[A4], Order1:=xlAscending, Header:=xlNo    'Àx¦s®æ±Æ§Ç
                .[A2] = xD.Count & "­Ó": .[A3] = "¸¹½X"
                Erase arr: xD.RemoveAll
            End If
        End With
    Next
    '     Sheets(Shrr).Copy
    '    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\TEST_" & Nrange & "-" & Num & "´Á" & ".xls"
    '    ActiveWindow.Close
    'MsgBox Timer - Tm
End Sub
{...} ªí¥Ü»Ý­n¥Î CTRL+SHIFT+ENTER ¤TÁä¿é¤J¤½¦¡

TOP

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