Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


36132 / 76732 ←次へ | 前へ→

【45783】Re:複数行の項目を同一項目で、1行にまとめたい・・・
回答  Hirofumi  - 07/1/14(日) 8:41 -

引用なし
パスワード
   Sheet1にデータが有るとして、列見出しが有る物とします
データは、A列〜C列の3列とします
結果は、Sheet2に出力に出力される物とします
実行時にA列昇順のB列昇順で整列され、終了直前に元の行位置に再整列されます

以下を標準モジュールに記述して下さい

Option Explicit

Public Sub Sample()

  '元々のデータ列数(A列〜C列)
  Const clngColumns As Long = 3
  
  Dim i As Long
  Dim j As Long
  Dim k As Long '★2重登録をスッキップ時に使用
  Dim lngRows As Long
  Dim lngTop As Long
  Dim lngCount As Long
  Dim lngMember() As Long
  Dim vntMember As Variant
  Dim lngMemberMax As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim lngWrite As Long
  Dim vntGroup As Variant
  Dim strProm As String

  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")

  '出力Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成
    ReDim vntData(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      vntData(i, 1) = i
    Next i
    '復帰用Keyの出力
    .Offset(1, clngColumns) _
          .Resize(lngRows).Value = vntData
    'データをA列昇順のB列昇順で整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1), Order1:=xlAscending, _
        Key2:=.Offset(1, 1), Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
            
    'Key(A列〜B列)データを配列に取得
    vntGroup = .Offset(1).Resize(lngRows + 1, 2).Value
  End With
  
  '園児数をカウントする配列を確保
  ReDim lngMember(1 To lngRows, 1 To 1)
  '出力行位置の初期値
  lngWrite = 1
  '先頭値の位置を記録
  lngTop = 1
  '同一グループ(保護者+住所)データ行数のカウント初期値
  lngCount = 1
  For i = 2 To lngRows + 1
    '注目行と現在行の値が(保護者+住所)違った場合
    If vntGroup(lngTop, 1) <> vntGroup(i, 1) _
        Or vntGroup(lngTop, 2) <> vntGroup(i, 2) Then
      '同一グループの園児名を配列に取得
      vntMember = rngList.Offset(lngTop, 2) _
                  .Resize(lngCount + 1).Value
      '園児数をカウント
      lngMember(lngWrite, 1) = lngCount
      '結果出力用配列を確保(保護者+住所+園児名1+園児名2・・)
      ReDim vntResult(1 To 2 + lngCount)
      '結果出力用配列に保護者、住所を転記
      vntResult(1) = vntGroup(lngTop, 1)
      vntResult(2) = vntGroup(lngTop, 2)
      '★サンプルデータでは、同一の保護者に同名の園児が
      '2人居る事に成ってますが?
      'データの2重登録をスッキップする場合、以下◎印を★印の様に
  '-----------------------------------------------------------------
      '結果出力用配列に園児を転記
      For j = 1 To lngCount '◎
        vntResult(2 + j) = vntMember(j, 1) '◎
      Next j '◎
      '園児数をカウント
      lngMember(lngWrite, 1) = lngCount '◎
      '園児数最大値を保存
      If lngMemberMax < lngCount Then '◎
        lngMemberMax = lngCount '◎
      End If '◎
  '-----------------------------------------------------------------
'      '結果出力用配列に園児を転記
'      k = 0 '★
'      For j = 1 To lngCount '★
'        If vntResult(2 + k) <> vntMember(j, 1) Then '★
'          k = k + 1 '★
'          vntResult(2 + k) = vntMember(j, 1) '★
'        End If '★
'      Next j '★
'      '園児数をカウント
'      lngMember(lngWrite, 1) = k '★
'      '園児数最大値を保存
'      If lngMemberMax < k Then '★
'        lngMemberMax = k '★
'      End If '★
  '-----------------------------------------------------------------
      '結果データを出力
      rngResult.Offset(lngWrite).Resize(, _
                2 + lngCount).Value = vntResult
      '出力行位置を更新
      lngWrite = lngWrite + 1
      '注目行の位置を記録
      lngTop = i
      '同一グループ(保護者+住所)データ行数のカウント初期値に
      lngCount = 1
    Else
      '同一グループ(保護者+住所)データ行数のカウントを更新
      lngCount = lngCount + 1
    End If
  Next i
  With rngResult
    '園児数を出力
    .Offset(1, 2 + lngMemberMax) _
      .Resize(lngWrite - 1).Value = lngMember
    '結果シートに列見出しを出力
    rngList.Resize(, 2).Copy Destination:=rngResult
    ReDim vntResult(1 To lngMemberMax + 1)
    For i = 1 To lngMemberMax
      vntResult(i) = "園児名"
    Next i
    vntResult(lngMemberMax + 1) = "園児数"
    .Offset(, 2).Resize(, lngMemberMax + 1).Value = vntResult
  End With
    
  With rngList
    '元データを復帰
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    
    '復帰用Key列を削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
   
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
   
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

1 hits

【45777】複数行の項目を同一項目で、1行にまとめたい・・・ NOKO 07/1/14(日) 2:49 質問
【45781】Re:複数行の項目を同一項目で、1行にまと... Kein 07/1/14(日) 4:07 回答
【45783】Re:複数行の項目を同一項目で、1行にまと... Hirofumi 07/1/14(日) 8:41 回答
【45792】Re:複数行の項目を同一項目で、1行にまと... Hirofumi 07/1/14(日) 15:08 回答

36132 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free