| |
こんな事で善いのかな？
理解して居なかったらごめん
Option Explicit
Public Sub Main()
'画面更新を停止
Application.ScreenUpdating = False
'１シート分処理
Transfer ActiveSheet.Range("A5:T13"), Worksheets("H22").Range("A1")
'画面更新を再開
Application.ScreenUpdating = True
MsgBox "処理が完了しました", vbInformation
End Sub
Private Sub Transfer(rngList As Range, rngResult As Range)
'1品目の行数
Const clngPitch As Long = 3
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
Dim lngRows As Long
Dim vntResult1 As Variant
Dim vntResult2 As Variant
Dim vntData As Variant
'結果シートに就いて
With rngResult
'最終行の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
lngRows = 0
End If
End With
'List範囲に就いて
With rngList
'年月日、店舗名を配列に取得
vntResult1 = .Cells(1, 1).Offset(-3).Resize(, 2).Value
'データ列が偶数であるのを確認し、奇数なら1列増やして偶数にし配列に取得
If .Columns.Count Mod 2 = 0 Then
'データを配列に取得
vntData = .Value
Else
vntData = .Resize(, .Columns.Count + 1).Value
End If
End With
'結果用配列を確保
ReDim vntResult2(1 To UBound(vntData, 1) * UBound(vntData, 2))
'データを結果用配列に転記
For i = 1 To UBound(vntData, 2) Step 2 '2列づつ処理
For j = 1 To UBound(vntData, 1) Step 3 '3行づつ処理
For k = 0 To 1 '奇数列、偶数列を処理
For l = 0 To 2 '品名、個数、金額を処理
m = m + 1
vntResult2(m) = vntData(j + l, i + k)
Next l
Next k
Next j
Next i
'データを出力
With rngResult
.Offset(lngRows + 1).Resize(, UBound(vntResult1, 2)).Value = vntResult1
.Offset(lngRows + 1, UBound(vntResult1, 2)) _
.Resize(, UBound(vntResult2)).Value = vntResult2
End With
'データを消去
' With rngList
' .Cells(1, 1).Offset(-3).Resize(, 2).ClearContents
' .ClearContents
' End With
End Sub
|
|
Hirofumi
- 10/4/10(土) 23:57 -
