(VBA)対応する番号の下に行挿入して文字列を追加

質問

以下を行うVBAのコードを知りたい

シート名「Extra」のA列に文字列が複数行に渡って記入されています
必ずA1は１で数行後に2と以後連番が続く形式です。

Sheets名「Time」は、
A列に1から始まる連番
B列にA列に対応する文字列が対であります。

やりたいことは、
「Time」のA列の連番と「Extra」にある同じ連番行の一つ下に行を挿入して
「Time」のA列と同じ行のB列の文字列を書き込みです。

例えば、「Extra」が

435
ABC

で

「Time」

435　123456
ならば

「Extra」を以下のように書き換える

435
123456
ABC

判りにくい内容でしょうがよろしくお願いします。

’-----------------------------------------

回答No.8

kkkkkm · ベストアンサー

> ret = Sheets("Extra_Original").Delete
> If ret = False Then
> Exit Sub
> End If

If ExistsSheet("Extra_Original") Then
が抜けてます。retは削除の時にキャンセルした時の対応ですのでシートの有無はチェックしたほうがいいのではないでしょうか。

If ExistsSheet("Extra_Original") Then
ret = Sheets("Extra_Original").Delete
If ret = False Then
Exit Sub
End If
End If

回答No.7

kkkkkm

回答No.5で

> これだと、途中に該当シートがあって以降別シートがある場合該当シートは存在しないという結果報告になりませんか

と、だらだら書きましたが

途中がどうであれ最後のシートが該当シートかどうかだけで結果判定されないでしょうか。

ですね。

回答No.6

kkkkkm

今気が付いたのですが

Sheets("Extra_Original").Delete

の時に確認のダイアログが出ると思いますがそこでキャンセルするとエラーになりますので

Dim ret As Boolean

で

ret = Sheets("Extra_Original").Delete
If ret = False Then
Exit Sub
End If

のようにしておいてはいかがでしょう。

お礼

kkkkkmさん、ダメ出しありがとうございます。

アドバイスを受けてコードを修正しました。

Sub Test() '対応する番号の下に行挿入して文字列を追加

Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Dim SheetName As String
Dim i As Long, j As Long
Dim ret As Boolean

Set Ws1 = Sheets("Extra")
Set Ws2 = Sheets("Time")

ret = Sheets("Extra_Original").Delete
If ret = False Then
Exit Sub
End If

Worksheets("Extra").Copy After:=Worksheets(Worksheets.count)
ActiveSheet.Name = "Extra_Original"

For i = Ws1.Cells(Rows.count, "A").End(xlUp).Row To 1 Step -1
For j = Ws2.Cells(Rows.count, "A").End(xlUp).Row To 1 Step -1
If Ws1.Cells(i, "A").Value = Ws2.Cells(j, "A").Value Then
Ws1.Rows(i + 1).Insert
Ws1.Cells(i + 1, "A").Value = Ws2.Cells(j, "B").Value
Exit For
End If
Next
Next

Set Ws1 = Nothing
Set Ws2 = Nothing

End Sub

Public Function ExistsSheet(ByVal bookName As String) As Boolean
Dim ws As Worksheet
For Each ws In Sheets
If LCase(ws.Name) = LCase(bookName) Then
ExistsSheet = True ' 存在する
Exit For
Else
ExistsSheet = False ' 存在しない
End If
Next
End Function

回答No.5

kkkkkm

> ＞ドロップダウンが出るので「うむうむよしよし」的な気分になります。
>
> これは、どういう意味でしょうか　？

タイプミスしているとドロップダウンは出ないのでミスなく出て満足じゃのようなことです。

For Each ws In Sheets
If LCase(ws.Name) = LCase(bookName) Then
ExistsSheet = True ' 存在する
Else
ExistsSheet = False ' 存在しない
End If
Next

これだと、途中に該当シートがあって以降別シートがある場合該当シートは存在しないという結果報告になりませんか

ExistsSheet = True ' 存在する
Exit For

で抜けるとかした方がいいような気がします。

回答No.4

kkkkkm

> ＞ドロップダウンが出るので「うむうむよしよし」的な気分になります。
>
> これは、どういう意味でしょうか　？

タイプミスしているとドロップダウンは出ないのでミスなく出て満足じゃのようなことです。

回答No.3

kkkkkm

細かい事でどちらでもいい話かもしれませんが

Public Function ExistsSheet(ByVal bookName As String)

戻り値の型指定がないのを書いた記憶が無かったので、Functionの戻り値のデータ型指定がなく一瞬戸惑いました。

Public Function ExistsSheet(ByVal bookName As String) As Boolean

としておくと
ExistsSheet =
でTrueとFalseのドロップダウンが出るので「うむうむよしよし」的な気分になります。
(オプションで自動メンバー表示にしておけばですが)
コードを見た時にも何を戻り値にしてるのか分かるのでいいと思いますし、間違った型を返そうとしたらエラーになりますのでその点もいいのではないかなと思います。(ただ、Booleanの場合は数値を返すとエラーにならないのですが)

あとbookNameだったのでブックがどこかで出てくるのかとしばらくコードを眺めました。

Dim ws As Variant
はシートなので
Dim ws As Worksheet
がいいのではないでしょうか。

お礼

アドバイスありがとうございます。

継ぎ足しのコードなのでやはりおかしかったですね。

以下に修正しました。

Public Function ExistsSheet(ByVal bookName As String) As Boolean
Dim ws As Worksheet
For Each ws In Sheets
If LCase(ws.Name) = LCase(bookName) Then
ExistsSheet = True ' 存在する
Else
ExistsSheet = False ' 存在しない
End If
Next
End Function

As Boolean　で戻り値がどんな形式かがすぐわかるので宣言すべきですね。

＞ドロップダウンが出るので「うむうむよしよし」的な気分になります。

これは、どういう意味でしょうか　？

回答No.2

kkkkkm

ExtraのA列が数値の時だけTimeを検索するのでしたら

Sub Test3()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long, LastRow As Long

Set Ws1 = Sheets("Extra")
Set Ws2 = Sheets("Time")

LastRow = Ws2.Cells(Rows.Count, "A").End(xlUp).Row

For i = Ws1.Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
If IsNumeric(Ws1.Cells(i, "A").Value) Then
For j = LastRow To 1 Step -1
If Ws1.Cells(i, "A").Value = Ws2.Cells(j, "A").Value Then
Ws1.Rows(i + 1).Insert
Ws1.Cells(i + 1, "A").Value = Ws2.Cells(j, "B").Value
LastRow = j - 1
Exit For
End If
Next
End If
Next

Set Ws1 = Nothing
Set Ws2 = Nothing

End Sub

お礼

kkkkkmさん、毎回お世話になりありがとうございます。

テストDATAで実際に３つのコードを検証しました。

結果、全ての満足な状態で出力されました。

コードをお借りしてコードを以下のように修正しました
何かアドバイス有ればお願いします。

Sub AddTimeLine()
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Dim SheetName As String
Dim i As Long, j As Long

Set Ws1 = Sheets("Extra")
Set Ws2 = Sheets("Time")

If ExistsSheet("Extra_Original") Then
Sheets("Extra_Original").Delete
End If

Worksheets("Extra").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Extra_Original"

For i = Ws1.Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
For j = Ws2.Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
If Ws1.Cells(i, "A").Value = Ws2.Cells(j, "A").Value Then
Ws1.Rows(i + 1).Insert
Ws1.Cells(i + 1, "A").Value = Ws2.Cells(j, "B").Value
Exit For
End If
Next
Next

Set Ws1 = Nothing
Set Ws2 = Nothing

End Sub

Public Function ExistsSheet(ByVal bookName As String)
Dim ws As Variant
For Each ws In Sheets
If LCase(ws.Name) = LCase(bookName) Then
ExistsSheet = True ' 存在する
Exit Function
End If
Next

' 存在しない
ExistsSheet = False
End Function

回答No.1

kkkkkm

Sub Test()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long

Set Ws1 = Sheets("Extra")
Set Ws2 = Sheets("Time")

For i = Ws1.Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
For j = Ws2.Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
If Ws1.Cells(i, "A").Value = Ws2.Cells(j, "A").Value Then
Ws1.Rows(i + 1).Insert
Ws1.Cells(i + 1, "A").Value = Ws2.Cells(j, "B").Value
Exit For
End If
Next
Next

Set Ws1 = Nothing
Set Ws2 = Nothing

End Sub

というようにいつも全てのデータをチェックするのではなく、連番なので既にチェックしたデータは外したいという事だとしたら

Sub Test2()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long, LastRow As Long

Set Ws1 = Sheets("Extra")
Set Ws2 = Sheets("Time")

LastRow = Ws2.Cells(Rows.Count, "A").End(xlUp).Row

For i = Ws1.Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
For j = LastRow To 1 Step -1
If Ws1.Cells(i, "A").Value = Ws2.Cells(j, "A").Value Then
Ws1.Rows(i + 1).Insert
Ws1.Cells(i + 1, "A").Value = Ws2.Cells(j, "B").Value
LastRow = j - 1
Exit For
End If
Next
Next

Set Ws1 = Nothing
Set Ws2 = Nothing

End Sub