質問です。

Question

inosisi

146

144もっと見る

60pt

コンピュータインターネット

質問です。

下記データをB列の種別ごとに集計できる関数またはマクロをお願いします。
　答え
　B列　　　　　　G列　　　　　　　　　　H列　　I列　　　J列
AAAAAA　　　0000-00-00 00:00:00　　　0　　0
AAAAAA　　　2011/4/27 19:12:00　　　　0　　0　　　DoCoMo
AAAAAA　　　0000-00-00 00:00:00　　　1　　1
AAAAAA　　　0000-00-00 00:00:00　　　0　　0　　　KDDI
AAAAAA　　　2011/4/30 19:12:00　　　0　　0
AAAAAA　　　　　　2　　　　　　　　　　　5　　4　　　　2　　
BBBBBB　　　2011/4/29 19:12:00　　　　0　　1　　　　DoCoMo
BBBBBB　　　0000-00-00 00:00:00 　　1　　0
BBBBBB　　　0000-00-00 00:00:00 　　0　　1　　　KDDI
BBBBBB　　　2011/4/28 19:12:00　　　0　　0
BBBBBB　　　　　　2　　　　　　　　　　　4　　2　　　　2

B列のコードの最後に同じコード名を1行足して表示し
その行に各列の集計をする。
G列は0以外の日付の入った件数
H列は全件数
I列は0の件数
J列は表示文字の件数

よろしくお願いします。

回答の条件

1人3回まで

登録：2011/05/04 12:38:14
終了：2011/05/04 14:25:47

※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

Silvanus 2011/05/04 14:40:29

先越されちゃいましたねｗ
http://rct3jp.info/hatena/hatena_inosisi4141_110504.xls
－－－－－
Option Explicit

Sub Hatena_inosisi4141_110504()

' ※注意※
' データの途中に空白行が存在するケースは想定していません。
' 現バージョンでは、空白のコード列を検出した行で処理が停止する様になっています。

Const lngRowTop As Long = 1 ' 処理を開始する行の番号
' 見出し行がある場合は、実際にデータが
' 格納されている最初の行の番号を指定して下さい｡

' 列番号
Const strCCode As String = "B" ' コード
Const strCDate As String = "G" ' 日付
Const strCNum1 As String = "H" ' 数字１
Const strCNum2 As String = "I" ' 数字２
Const strCCarr As String = "J" ' 携帯電話キャリア

Dim lngRowCount As Long ' 行カウンタ
Dim lngRowStart As Long ' 同一のコードが入力されている最初の行を格納
Dim lngCCIsDate As Long ' 有効な日付が入力されているセルのカウンタ

lngCCIsDate = 0
lngRowCount = lngRowTop
lngRowStart = lngRowCount

Do
Do
lngCCIsDate = lngCCIsDate - IsDate(Cells(lngRowCount, strCDate)) ' 有効な日付が入力されていたらカウンタ＋１
lngRowCount = lngRowCount + 1
Loop Until Cells(lngRowCount, strCCode).Value <> Cells(lngRowCount - 1, strCCode).Value ' 同じコードが続いているならループ
Rows(lngRowCount).Insert Shift:=xlShiftDown ' １行挿入
Cells(lngRowCount, strCCode).Value = Cells(lngRowCount - 1, strCCode).Value ' 挿入行にコード記入
Cells(lngRowCount, strCDate).Value = lngCCIsDate ' 挿入行に有効な日付が入力されたセル数を記入
Cells(lngRowCount, strCDate).NumberFormatLocal = "G/標準" ' ＆そのセルの書式を「標準」に設定(日付形式になるのを防ぐ)
' (下３行) 数字１/２、キャリアのカウント
Cells(lngRowCount, strCNum1).Value = Application.Count(Range(Cells(lngRowStart, strCNum1), Cells(lngRowCount - 1, strCNum1)))
Cells(lngRowCount, strCNum2).Value = Application.CountIf(Range(Cells(lngRowStart, strCNum2), Cells(lngRowCount - 1, strCNum2)), 0)
Cells(lngRowCount, strCCarr).Value = Application.CountA(Range(Cells(lngRowStart, strCCarr), Cells(lngRowCount - 1, strCCarr)))
lngRowCount = lngRowCount + 1
lngRowStart = lngRowCount ' 同一コードが入力されている最初の行をリセット
lngCCIsDate = 0 ' 有効な日付が入力されているセルのカウンタをリセット
Loop Until Application.CountA(Cells(lngRowCount, strCCode)) = 0

End Sub

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

リクエスト送信済

回答リクエストを送信したユーザーはいません

SALINGER · Accepted Answer · 2011-05-04T13:51:41+09:00

B列は同じ値が連続するとして作成しています。

連続していない場合はB列でソートすればいいです。

また、G列の日付以外の文字列は"0000-00-00 00:00:00"としています。

過去の質問の"0000/00/00 00:00:00"を使っている場合はコード中のその部分を変更してください。

先頭行は１行目からにしていますが、２行目からの場合は１０行目の

stRow = 1

を

stRow = 2

にしてください。

Sub Macro()
    Dim i As Long
    Dim lastRow As Long
    Dim stRow As Long
    Dim myG As Long
    Dim myH As Long
    Dim myI As Long
    Dim myJ As Long
    Dim c As Long
    
    stRow = 1
    lastRow = Cells(Rows.Count, "B").End(xlUp).Row
    
    For i = stRow To lastRow
        If Cells(i + c, "G").Text <> "0000-00-00 00:00:00" And Cells(i + c, "G").Value > 0 Then
            myG = myG + 1
        End If
    
        myH = myH + 1
        
        If Cells(i + c, "I").Value = 0 Then
            myI = myI + 1
        End If
        
        If Cells(i + c, "J").Value <> "" Then
            myJ = myJ + 1
        End If
        
        If Cells(i + c, "B").Value <> Cells(i + c + 1, "B").Value Then
            Rows(i + c + 1).Insert
            c = c + 1
            Cells(i + c, "B").Value = Cells(i + c - 1, "B").Value
            Cells(i + c, "G").NumberFormatLocal = "G/標準"
            Cells(i + c, "G").Value = myG
            Cells(i + c, "H").Value = myH
            Cells(i + c, "I").Value = myI
            Cells(i + c, "J").Value = myJ
            myG = 0
            myH = 0
            myI = 0
            myJ = 0
        End If
    Next i
    
End Sub

質問です。

ベストアンサー

SALINGER34549692011/05/04 13:51:41

コメント（1件)

この質問への反応（ブックマークコメント）