| |
▼よっちゃん さん：
>多くても、一つの項目で10行くらいに収まるようにはしていますが、
Option Explicit
Sub test()
Dim 表 As Range, 転記先 As Range
Dim 期間 As String
Dim s
Dim 列 As Range
Dim r As Range, c As Range
Dim 項目 As String, 内容 As String
Dim n As Long
Dim 開始月 As Date, 終了月 As Date
Dim d As Date
Set 表 = Sheets("Sheet1").Range("B22:F22").Offset(1).Resize(100)
Set 転記先 = Sheets("Sheet2").Range("A2")
期間 = "20/4月〜21/1月"
s = Split(Replace(期間, "月", ""), "〜")
開始月 = DateValue("20" & s(0) & "/1")
終了月 = DateValue("20" & s(1) & "/1")
For Each 列 In 表.Columns
Set r = Nothing
On Error Resume Next
Set r = 列.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not r Is Nothing Then
項目 = 列.Cells(0).Value
For Each c In r
内容 = c.Value
d = 開始月
Do
n = n + 1
転記先.Cells(n, 1).Value = 項目
転記先.Cells(n, 2).Value = 内容 & Format(d, "(yy/m月分)")
d = WorksheetFunction.EDate(d, 1)
Loop Until d > 終了月
Next
End If
Next
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
