| |
データシートの内容が殆ど解らないので上手く行くかは？だけど作って見ました
一応、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
|
|
Hirofumi
- 06/2/12(日) 18:50 -
