[¤À¨É] ¥HÄ渹 ­p¾ãÄæ¦h¤Ö¼Æ¦r (14532)

hcm19522

¤U¸ü (10.4 KB)

2025-11-12 17:15

hcm19522

(·j´M ¿é¤J¸¹½X 14532) googleºô§}:https://hcm19522.blogspot.com/

Andy2483

¦^´_ 1# hcm19522


    ÁÂÁ«e½ú¤À¨É¦¹¥DÃD,«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð«e½ú­Ì«ü±Ð

°õ¦æ«e:

¤U¸ü (79.92 KB)

2025-11-20 16:25

°õ¦æµ²ªG:

¤U¸ü (82.68 KB)

2025-11-20 16:26

Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 2), K, Z, i&, j%, N&
Set Z = CreateObject("Scripting.Dictionary")
Brr = [A1:AB1].Resize(ActiveSheet.UsedRange.Rows.Count)
For j = 1 To UBound(Brr, 2)
   For i = 1 To UBound(Brr)
      If IsNumeric(Brr(i, j)) And Brr(i, j) <> "" Then Z(j) = Z(j) + 1
   Next
Next
For Each K In Z.Keys
   N = N + 1
   Crr(N, 1) = Split(Cells(1, K).Address, "$")(1)
   Crr(N, 2) = Z(K)
Next
If N > 0 Then [AD2].Resize(N, 2) = Crr
End Sub

Quake

©³¤U¬O½Ð§Ú¹j¾À¾F©~ChatGPTÀ°§Ú¼gªºµ{¦¡½X

Sub CountNumbersInColumns()

    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim r As Long, c As Long
    Dim countNum As Long
    Dim outCol As Long
    Dim outRow As Long
    Dim colLetter As String
   
    Set ws = ActiveSheet

    '¦Û°Ê°»´ú¾ã±i¤u§@ªí¯u¥¿ªº³Ì«á¦C
    lastRow = ws.Cells.Find(What:="*", _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious).Row

    '¦Û°Ê°»´ú¾ã±i¤u§@ªí¯u¥¿ªº³Ì«áÄæ
    lastCol = ws.Cells.Find(What:="*", _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious).Column

    '¿é¥X±q¸ê®Æ¥k°¼¨âÄæ¶}©l
    outCol = lastCol + 2
    outRow = 2 '±q²Ä 2 ¦C¶}©l¿é¥X¡]²Ä 1 ¦C«O¯d·íªíÀY¡^

    '²M°£Â¸ê®Æ
    ws.Columns(outCol).Resize(, 2).ClearContents

    'ªíÀY
    ws.Cells(1, outCol).Value = "Ä渹"
    ws.Cells(1, outCol + 1).Value = "µ²ªG"

    '³vÄæ²Î­p
    For c = 1 To lastCol
        countNum = 0

        For r = 1 To lastRow
            If IsNumeric(ws.Cells(r, c).Value) And ws.Cells(r, c).Value <> "" Then
                countNum = countNum + 1
            End If
        Next r

        '­Yµ²ªG¬° 0¡A¸õ¹L¤£¿é¥X
        If countNum > 0 Then

            '¨ú±oÄæ¦r¥À¡A¨Ò¦p "C"
            colLetter = Replace(Split(ws.Cells(1, c).Address(False, False), "$")(0), "1", "")

            '¿é¥X
            ws.Cells(outRow, outCol).Value = colLetter
            ws.Cells(outRow, outCol + 1).Value = countNum

            outRow = outRow + 1
        End If
    Next c

    MsgBox "²Î­p§¹¦¨¡I", vbInformation
End Sub