Excel VBA質問箱 IV

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

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


46916 / 76736 ←次へ | 前へ→

【34787】Re:複数にわたるデータを一行に纏める方法
回答  Hirofumi  - 06/2/12(日) 18:50 -

引用なし
パスワード
   データシートの内容が殆ど解らないので上手く行くかは?だけど作って見ました
一応、A列、B列の1行目からデータが有る物としています
また、内訳が、列見出しに出力する物以外が出た場合、無視されます

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim lngRows As Long
  Dim lngRow As Long
  Dim lngColumn As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim rngResult As Range
  Dim vntColumns As Variant
  Dim strProm As String
  
  '結果出力Listの左上隅セル位置を基準として設定(見出しの「データ名」のセル位置)
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  With rngResult
    '行見だしを保持する配列を仮に確保
    ReDim vntRows(0)
    '列見だしを配列に取得(実際に含まれる文字列に修正する事)
    vntColumns = Array("合計", "内訳1", "内訳2", "内訳3", "内訳4", "内訳5", "内訳6")
    '列見だしを出力
    .Value = "データ名"
    .Offset(, 1).Resize(, UBound(vntColumns) + 1).Value = vntColumns
  End With
  
  'データListの左上隅セル位置を基準として設定
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  With rngList
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
    'データが無い場合
    If lngRows <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得
    vntData = .Resize(lngRows, 2).Value
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '集計
  For i = 1 To lngRows
    'A列の値に"データ名"が含まれる場合(実際にセルに書いて有る値に含まれる文字列にする事)
    If InStr(1, vntData(i, 1), "データ名", vbTextCompare) > 0 Then
      '出力行を更新
      lngRow = lngRow + 1
      'データ名を結果シートに出力
      rngResult.Offset(lngRow).Value = vntData(i, 2)
    Else
      'A列の値が、どの内訳に当たるか探索
      lngColumn = GetColumnPos(vntData(i, 1), vntColumns)
      '該当する内訳が有った場合
      If lngColumn > 0 Then
        '結果シートにB列の値を書き込む
        rngResult.Offset(lngRow, lngColumn).Value = vntData(i, 2)
      End If
    End If
  Next i
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetColumnPos(vntKey As Variant, _
              vntScope As Variant) As Long

  Dim i As Long
  Dim lngListEnd As Long
  
  '行見出しの行数を取得
  lngListEnd = UBound(vntScope, 1)
  '範囲からKeyを探索
  For i = 0 To lngListEnd
    'もし、行見出しと探索Keyが合致したら戻り値として行位置を返す
    If InStr(1, vntKey, vntScope(i), vbTextCompare) > 0 Then
      GetColumnPos = i + 1
      Exit Function
    End If
  Next i

End Function

0 hits

【34644】複数にわたるデータを一行に纏める方法 初心者m(__)m 06/2/9(木) 9:31 質問
【34649】Re:複数にわたるデータを一行に纏める方法 ちくたく 06/2/9(木) 10:31 発言
【34674】Re:複数にわたるデータを一行に纏める方法 初心者m(__)m 06/2/9(木) 16:56 お礼
【34658】Re:複数にわたるデータを一行に纏める方法 Kein 06/2/9(木) 13:34 回答
【34673】Re:複数にわたるデータを一行に纏める方法 初心者m(__)m 06/2/9(木) 16:53 お礼
【34784】Re:複数にわたるデータを一行に纏める方法 初心者2 06/2/12(日) 15:07 質問
【34786】Re:複数にわたるデータを一行に纏める方法 Kein 06/2/12(日) 18:01 発言
【34789】Re:複数にわたるデータを一行に纏める方法 初心者2 06/2/13(月) 7:48 質問
【34787】Re:複数にわたるデータを一行に纏める方法 Hirofumi 06/2/12(日) 18:50 回答

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