| |
列見出しを付けるついでに、「シートB」の結果を消去する様にしました
Option Explicit
Public Sub Sample2()
'◆Listデータ列数（A列〜G列）
Const clngColumns As Long = 7
'PDの始まる列位置を指定（基準位置からの列Offsetで指定:C列）
Const clngPD As Long = 2
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntData As Variant
Dim vntResult As Variant
Dim lngWrite As Long
Dim vntPD As Variant
Dim strProm As String
'◆Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngList = Worksheets("シートＡ").Cells(1, "A")
'◆結果の先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngResult = Worksheets("シートＢ").Cells(1, "A")
With rngResult
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows > 0 Then
.Parent.UsedRange.ClearContents
End If
.Resize(, 4).Value = Array("CD", "NAME", "PD", "MB")
End With
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
' lngRows = lngRows - 1 '★削除（無くても構わなかった）
'PDを配列に取得
vntPD = .Resize(, clngColumns).Value
'基準位置を1つ下に変更
' Set rngList = .Offset(1) '★削除（無くても構わなかった）
End With
'結果用配列を確保
ReDim vntResult(1 To 4)
'画面更新を停止
Application.ScreenUpdating = False
For i = 1 To lngRows
'Listから1行分を配列に取得
vntData = rngList.Offset(i).Resize(, clngColumns).Value
'先頭2列を結果配列に転記
For j = 1 To 2
vntResult(j) = vntData(1, j)
Next j
'3列目から後ろ見て行く
For j = clngPD + 1 To clngColumns
If vntData(1, j) <> "" Then
'PD、MBを転記
vntResult(3) = vntPD(1, j)
vntResult(4) = vntData(1, j)
'"シートＢ"に転記
lngWrite = lngWrite + 1
rngResult.Offset(lngWrite).Resize(, UBound(vntResult)).Value = vntResult
End If
Next j
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 08/10/7(火) 18:33 -
