| |
▼ラッキー さん：
こんばんは
Sub test()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim Sh3 As Worksheet
Dim r As Range
Dim t As Variant
Dim h As Long
Dim i As Long
Dim j As Long
Set Sh1 = ThisWorkbook.Worksheets("Sheet1") '元データ
Set Sh2 = ThisWorkbook.Worksheets("Sheet2") '転記先シート セルB1「start」、C1「end」
Set Sh3 = ThisWorkbook.Worksheets("Sheet3") 'テーブル
Application.ScreenUpdating = False
Sh2.UsedRange.ClearContents
Sh2.Range("B1").Value = "start"
Sh2.Range("C1").Value = "end"
Call テーブル作成(Sh3, WorksheetFunction.Max(Sh1.Columns(2)))
h = 2
For Each r In Sh1.Range("B1", Sh1.Range("B" & Rows.Count).End(xlUp))
t = Application.Match(r.Value, Sh3.Columns(2), 1)
If IsError(t) Then
Sh2.Cells(h, 1) = r.Offset(0, -1).Value
Sh2.Cells(h, 2) = 1
Sh2.Cells(h, 3) = r.Value
Else
If Sh3.Cells(t, 2) = r.Value Then
i = t
Else
i = t + 1
End If
Sh2.Cells(h, 1).Resize(i) = r.Offset(0, -1).Value
Sh2.Cells(h, 2).Resize(i, 2) = _
Sh3.Range("A1").Resize(i, 2).Value
Sh2.Cells(h + i - 1, 3) = r.Value
End If
h = Sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
Next
Application.ScreenUpdating = True
End Sub
Sub テーブル作成(sh As Worksheet, v As Long)
Dim x As Long
x = Round(v / 1000) + 1
With sh
.UsedRange.ClearContents
.Range("A1").Value = "1"
.Range("A2").Value = "1001"
.Range("B1").Value = "1000"
.Range("B2").Value = "2000"
If x > 2 Then
.Range("A1:A2").AutoFill Destination:=.Range("A1:A" & x), Type:=xlFillDefault
.Range("B1:B2").AutoFill Destination:=.Range("B1:B" & x), Type:=xlFillDefault
End If
End With
End Sub
>とても悩んでいるので教えて下さい。
>
>A 2500
>B 1300
>C 200
>
>のような表があります。
>それを
>
> start end
>A 1 1000
>A 1001 2000
>A 2001 2500
>B 1 1000
>B 1001 1300
>C 1 200
>
>というように1000単位でばらした表を作成したいのですが、
>とっかかりすら思いつきません。
>どうかお知恵をお貸しくださいませ。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
