| |
Sheet1 にその表があって、Sheet2(空白シート) に転記するとします。
以下のコードを試してみて下さい。速度は特に考慮していませんが、20000行でも
それほど遅いとは感じないはずです。
Sub Test_Align()
Dim MyR1 As Range, MyR2 As Range, C As Range
Dim i As Long, x As Long
Dim CkV As String, MyV As Variant
Application.ScreenUpdating = False
With Sheets("Sheet1")
With .Range("A1", .Range("A65536").End(xlUp)).Offset(, 26)
.Formula = "=IF(MID($A1,4,1)=""名"",1,""A"")"
Set MyR1 = .SpecialCells(3, 1)
Set MyR2 = .SpecialCells(3, 2)
.ClearContents
End With
Intersect(MyR1.EntireRow, .Range("A:A")) _
.Copy Sheets("Sheet2").Range("A2")
End With
Sheets("Sheet2").Range("B1:H1").Value = Array("合計", "内訳1", _
"内訳2", "内訳3", "内訳4", "内訳5", "内訳6"): i = 2
For Each C In MyR2.Areas
CkV = C.Offset(, -26).Range("A1").Value
MyV = WorksheetFunction.Transpose(C.Offset(, -25).Value)
If Right$(CkV, 2) = "合計" Then
x = 2
Else
x = 3
End If
Sheets("Sheet2").Cells(i, x).Resize(, UBound(MyV)).Value = MyV
i = i + 1
Next
Application.ScreenUpdating = True
Set MyR1 = Nothing: Set MyR2 = Nothing
End Sub
|
|
Kein
- 06/2/9(木) 13:34 -
