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