VBA教えてください。初心者です。続きです。

質問

前回の質問No.9231449、補足で新しい画像を添付します。
ご覧いただけるとおわかりだと思いますが、ランダムに旅行行程がならんでいるので、それを順番通りに並び替えたいです。4つのシートにばらばらになっています。添付のシートは一枚目のシートで、B列が順番なのですが2.3.5.6.10.。。と並んでおり、二枚目のシートは3.8、三枚目のシートは1.9というように、複数のシートにちらばって順不同でならんでいるので、新しいシートに順番通りにつなげられるVBAがあれば、教えてください。

回答No.6

kkkkkm

No5です。

> 各シートのB列の最後の番号の入った行より下で一行データのない行があると、その上の行までしかその行程と認識しません。

上記訂正です。最後の番号ではなく
各行程で一行データのない行があるとその上の行までしかその行程と認識しません。
です。

回答No.5

kkkkkm

> 行数は固定ではなく、バラバラです。

バラバラのパターンです。ただし、各シートのB列の最後の番号の入った行より下で一行データのない行があると、その上の行までしかその行程と認識しません。
たとえば、17行目から25行目までが一行程だけど20行目のB20からJ20までまるまるデータのない場合19行目までがその行程となります。20行目のBからJまでのどこかのセルにデータがあれば大丈夫です。

Sub Example()
Dim buf As Variant
Dim OrigLastRow As Long, MatchRow As Long, LastRow As Long, RangeLastRow As Integer
Dim i As Integer, j As Integer
Dim OrderAry() As Integer
Dim ws(3) As Worksheet, NewSh As Worksheet

Set NewSh = Sheets("新しいシート")
'実際の並んだデータを作成するシート名に変更してください。
'自動では作成されません毎回同じシートを利用します。
Set ws(0) = Sheets("Sheet1")
Set ws(1) = Sheets("Sheet2")
Set ws(2) = Sheets("Sheet3")
Set ws(3) = Sheets("Sheet4")
'実際の4つのシート名を記載してください。
Application.ScreenUpdating = False
With NewSh
.Range(.Cells(1, "A"), .Cells(.Cells.SpecialCells(xlCellTypeLastCell).Row, "J")).Clear
End With
With ws(0)
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
OrigLastRow = .Cells(LastRow, "B").CurrentRegion.Item(.Cells(LastRow, "B").CurrentRegion.Count).Row
End With
For i = 1 To 3
With ws(i)
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
.Range(.Cells(2, "B"), .Cells(.Cells(LastRow, "B").CurrentRegion.Item(.Cells(LastRow, "B").CurrentRegion.Count).Row, "J")).Copy
LastRow = ws(0).Cells(Rows.Count, "B").End(xlUp).Row
ws(0).Cells(ws(0).Cells(LastRow, "B").CurrentRegion.Item(ws(0).Cells(LastRow, "B").CurrentRegion.Count).Row + 1, "B").PasteSpecial
End With
Next i
j = 0
With ws(0)
For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
If .Cells(i, "B") <> "" Then
ReDim Preserve OrderAry(j)
OrderAry(j) = .Cells(i, "B").Value
j = j + 1
End If
Next i
End With
For i = LBound(OrderAry) To UBound(OrderAry)
For j = UBound(OrderAry) To i Step -1
If OrderAry(i) > OrderAry(j) Then
buf = OrderAry(i)
OrderAry(i) = OrderAry(j)
OrderAry(j) = buf
End If
Next j
Next i
With ws(0)
For i = LBound(OrderAry) To UBound(OrderAry)
MatchRow = WorksheetFunction.Match(OrderAry(i), .Range("B:B"), 0)
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
LastRow = .Cells(LastRow, "B").CurrentRegion.Item(.Cells(LastRow, "B").CurrentRegion.Count).Row
If .Cells(MatchRow, "B").End(xlDown).Row <= LastRow Then
RangeLastRow = .Cells(MatchRow, "B").End(xlDown).Row - 1
Else
RangeLastRow = LastRow
End If
If NewSh.Cells(1, "B").Value = "" Then
.Range(.Cells(MatchRow, "B"), .Cells(RangeLastRow, "J")).Copy _
NewSh.Cells(1, "B")
Else
.Range(.Cells(MatchRow, "B"), .Cells(RangeLastRow, "J")).Copy
With NewSh
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
.Cells(.Cells(LastRow, "B").CurrentRegion.Item(.Cells(LastRow, "B").CurrentRegion.Count).Row + 1, "B").PasteSpecial
End With
End If
Next i
.Activate
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
LastRow = .Cells(LastRow, "B").CurrentRegion.Item(.Cells(LastRow, "B").CurrentRegion.Count).Row
.Range(.Cells(OrigLastRow + 1, "B"), .Cells(LastRow, "J")).Clear
.Cells(1, 1).Select
End With
Application.CutCopyMode = False
NewSh.Activate
NewSh.Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub

回答No.4

ushi2015

こんばんは
Sub test2()
　　Dim sh As Worksheet
　　Dim tsh As Worksheet
　　Dim r As Range
　　Dim i As Long
　　Application.ScreenUpdating = False
　　Set tsh = Worksheets.Add
　　i = 1
　　'括弧内は実際のシート名に変更する
　　For Each sh In Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4"))
　　　　For Each r In sh.Range("B1:B" & sh.UsedRange.Rows.Count) _
　　　　　　　　　　　　　　.SpecialCells(xlCellTypeBlanks).Areas
　　　　　　With sh.Range(r.Offset(-1), r).Resize(, 9)
　　　　　　　　Application.Goto .Cells
　　　　　　　　.Copy tsh.Cells(i, 1)
　　　　　　　　tsh.Cells(i, 1).Resize(.Rows.Count).Offset(, 9).Value = .Cells(1, 1)
　　　　　　　　i = i + .Rows.Count
　　　　　　End With
　　　　Next
　　Next
　　tsh.UsedRange.Sort Key1:=tsh.Range("J1"), Order1:=xlAscending, Header:=xlNo
　　tsh.Range("J:J").ClearContents
　　Application.ScreenUpdating = True
End Sub
こちらのコードに差し替えて、コードの中のどこでもいいのでクリックしてから、
F8キーでステップ実行して下さい。
Application.GoTo でコピー元のセルが選択されるので1データ分が選択されるか
確認して下さい。
あと、結合されているセルがどこか教えて下さい。

回答No.3

ushi2015

こんばんは
元データが分からないのでダメですね。
止まる理由も分からないですが、セルが
結合されてたりしますか?

お礼

セルが結合されている場合もあると思います。添付ファイルが見づらくてすみませんでした。私には難しいプログラムなんですが、解読して理解できるように頑張ります。

回答No.2

ushi2015

こんばんは
画像が小さくて良く分からないです。
Sub test1()
　　Dim sh As Worksheet
　　Dim tsh As Worksheet
　　Dim r As Range
　　Dim i As Long
　　Application.ScreenUpdating = False
　　Set tsh = Worksheets.Add
　　i = 1
　　'括弧内は実際のシート名に変更する
　　For Each sh In Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4"))
　　　　For Each r In sh.Range("B1:B" & sh.UsedRange.Rows.Count) _
　　　　　　　　　　　　　　.SpecialCells(xlCellTypeBlanks).Areas
　　　　　　With sh.Range(r.Offset(-1), r).Resize(, 9)
　　　　　　　　.Copy tsh.Cells(i, 1)
　　　　　　　　tsh.Cells(i, 1).Resize(.Rows.Count).Offset(, 9).Value = .Cells(1, 1)
　　　　　　　　i = i + .Rows.Count
　　　　　　End With
　　　　Next
　　Next
　　tsh.UsedRange.Sort Key1:=tsh.Range("J1"), Order1:=xlAscending, Header:=xlNo
　　tsh.Range("J:J").ClearContents
　　Application.ScreenUpdating = True
End Sub
これで上手く行きますか？

お礼

With sh.Range(r.Offset(-1), r).Resize(, 9)のところで止まってしまいました。見にくい画像にも関わらずご回答いただいて本当にありがとうございます。

回答No.1

kkkkkm

以下のような感じでしょうか
旅行行程の1行程の行数が4行に見えたのでItemRows = 4 にしていますが、違う場合は変更してください。シート名は適宜変更してください。また、列はJ列までに見えるのでJ列までを作業の対象としています。新しいシート以外のすべてのシートは項目行が1行目でデータが2行目から始まっていると考えています。新しいシートには項目行もデータも何もないものとして考えています。

Sheet1にすべてコピーして作業してますので、Sheet1に必要なデータ以外があると正常に動作しません。

Sub Example()
Dim buf As Variant, flg As Boolean, ItemRows As Integer
Dim OrigLastRow As Long, MatchRow As Long
Dim i As Integer, j As Integer
Dim OrderAry() As Integer
Dim ws(3) As Worksheet, NewSh As Worksheet

ItemRows = 4 '旅行行程の1行程の行数
Set NewSh = Sheets("新しいシート")
'実際の並んだデータを作成するシート名に変更してください。
Set ws(0) = Sheets("Sheet1")
Set ws(1) = Sheets("Sheet2")
Set ws(2) = Sheets("Sheet3")
Set ws(3) = Sheets("Sheet4")
'実際の4つのシート名を記載してください。
Application.ScreenUpdating = False
With NewSh
.Range(.Cells(1, "B"), .Cells(.Cells(Rows.Count, "B").End(xlUp).Row + ItemRows - 1, "J")).Clear
End With
OrigLastRow = ws(0).Cells(Rows.Count, "B").End(xlUp).Row + ItemRows - 1
For i = 1 To 3
With ws(i)
.Range(.Cells(2, "B"), .Cells(.Cells(Rows.Count, "B").End(xlUp).Row + ItemRows - 1, "J")).Copy _
ws(0).Cells(ws(0).Cells(Rows.Count, "B").End(xlUp).Row + ItemRows, "B")
End With
Next i
j = 0
With ws(0)
For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row + ItemRows - 1 Step ItemRows
ReDim Preserve OrderAry(j)
OrderAry(j) = .Cells(i, "B").Value
j = j + 1
Next i
End With
For i = LBound(OrderAry) To UBound(OrderAry)
For j = UBound(OrderAry) To i Step -1
If OrderAry(i) > OrderAry(j) Then
buf = OrderAry(i)
OrderAry(i) = OrderAry(j)
OrderAry(j) = buf
End If
Next j
Next i
With ws(0)
For i = i = LBound(OrderAry) To UBound(OrderAry)
MatchRow = WorksheetFunction.Match(OrderAry(i), .Range("B:B"), 0)
If NewSh.Cells(1, "B").Value = "" Then
.Range(.Cells(MatchRow, "B"), .Cells(MatchRow + ItemRows - 1, "J")).Copy _
NewSh.Cells(1, "B")
Else
.Range(.Cells(MatchRow, "B"), .Cells(MatchRow + ItemRows - 1, "J")).Copy _
NewSh.Cells(NewSh.Cells(Rows.Count, "B").End(xlUp).Row + ItemRows, "B")
End If
Next i
.Activate
.Range(.Cells(OrigLastRow + 1, "B"), .Cells(.Cells(Rows.Count, "B").End(xlUp).Row + ItemRows - 1, "J")).Clear
.Cells(1, 1).Select
End With
Application.CutCopyMode = False
NewSh.Activate
Application.ScreenUpdating = True
End Sub

補足

行数は固定ではなく、バラバラです。バラバラでも作ることができますでしょうか・・。