エクセルvbaについて

Question

tatsumaru77様
以前投稿した内容で転記の追加をしたいのですが、内容は別ファイルへの転記をB列の1行目から添付の内容をお願いします。A列の転記内容はそのままでいいです。
AA0000Z00001*
B列にはS列とU列の転記はなしです。
それとこのコードだと転記した後に、もう一度転記処理を行うと最初に転記したものが消えてしまいます。一度転記したものは消さずにその下から転記されるようにしたいです。A列B列も同じようにです。
自分で変更してみましたが、うまくいきません。
申し訳ありませんが、よろしくお願いいたします。

Public Sub 別ファイルへ転記()
Dim fpath As String
Dim wb As Workbook
Dim ws1 As Worksheet
Dim wb2 As Workbook
Dim ws2 As Worksheet
Dim maxrow1 As Long
Dim row1 As Long
Dim row2 As Long
Set ws1 = ActiveSheet
fpath = "C:\Users	-tai\OneDrive\デスクトップ\図番\図番転記.xlsx"
Set wb2 = Nothing
For Each wb In Workbooks
If wb.Name = "図番転記.xlsx" Then
Set wb2 = wb
Exit For
End If
Next
If wb2 Is Nothing Then
Set wb2 = Workbooks.Open(fpath)
End If
Set ws2 = wb2.Worksheets(1)
ws2.Cells.ClearContents
row2 = 1
maxrow1 = ws1.Cells(Rows.Count, "C").End(xlUp).Row

For row1 = 13 To maxrow1
If ws1.Cells(row1, "A").Value = "○" Then
ws2.Cells(row2, "A").Value = ws1.Cells(row1, "C").Value & ws1.Cells(row1, "E").Value & ws1.Cells(row1, "K").Value & _
ws1.Cells(row1, "O").Value & ws1.Cells(row1, "S").Value & ws1.Cells(row1, "U").Value & "*"
row2 = row2 + 1
End If
Next

or row1 = 13 To maxrow1
If ws1.Cells(row1, "A").Value = "○" Then
ws2.Cells(row2, "Ｂ").Value = ws1.Cells(row1, "C").Value & ws1.Cells(row1, "E").Value & ws1.Cells(row1, "K").Value & _
ws1.Cells(row1, "O").Value & "*"
row2 = row2 + 1
End If
Next
End Sub

tatsumaru77 · Accepted Answer

>If ws1.Cells(row1, "A").Value <> "" Thenに変更しましたが、変わりはないです。

そうすると、そのマクロ自体が実行されていないように見えます。
１．A列の１３行目（A13）に〇を設定する。

２．下記行にブレイクポイントを設定する。
If ws1.Cells(row1, "A").Value <> "" Then
３．マクロを実行する。

４．If ws1.Cells(row1, "A").Value <> "" Then
の行で止まることを確認する。

５．F８でステップ実行する。

６．その後、どうなりますか。
①ws2.Cells(row2, "A").Value = ws1.Cells　以下省略が実行される。
②上記の①は実行されない。

上記①②のどちらでしょうか。

tatsumaru77 · Answer

不思議ですね。
確認１：
１３行目のA列に○があるのに、
ws2.Cells(row2, "A").Value = ws1.Cells(row1, "C").Value 以下省略
が実行されない。

確認３：
If ws1.Cells(row1, "A").Value = "○" Then　の○を
１３行目のA列にコピペしても、変わらず。

上記で、通常は、転記条件が成立するはずでが、何らかの原因で
転記条件が成立しないようです。

A列が、○と空欄しかないという前提になりますが、
        If ws1.Cells(row1, "A").Value = "○" Then　の行を
        If ws1.Cells(row1, "A").Value <> "" Then
に変えて実行してください。それで、どうなりますか。
それで、転記されるなら、A列の○が違っているか、A列の○の前後にスペースなどがあるかなどが考えられます。

tatsumaru77 · Answer

>頂いたコ－ドをを実行すると転記される側のファイルが開かれるのですが、>何も転記されません。特にエラーになるわけでもないのですが。

考えられるのは、何かの原因により転記元のデータが転記対象になっていない。
ということです。

確認１：
当然の話ですが、転記元シート（Sheet1）の１３行目以降に、
A列に○のついた行があるという前提です。
もし、ないなら、転記されません。

確認２：
①maxrow1 = 500　
②maxrow1 = ws1.Cells(Rows.Count, "C").End(xlUp).Row
のどちらを採用していますか？
もし、②を採用しているなら、①に変えてください。

確認３：
転記元の○が、提示したマクロの
        If ws1.Cells(row1, "A").Value = "○" Then
の○と同じか確認してください。
マクロの○を転記元のA列にコピペしてから、マクロを実行すれば
必ず一致します。

上記の確認を行ってください。

tatsumaru77 · Answer

追伸：
No2で、
①maxrow1 = 500　としていますが、
②maxrow1 = ws1.Cells(Rows.Count, "C").End(xlUp).Row
で問題なければ、②を採用してください。
前回の回答の時、②でエラーが発生するので、①にしてあります。

tatsumaru77 · Answer

失礼しました。No1は無視してください。
こちらが正しいです。
Option Explicit

Public Sub 別ファイルへ転記()
    Dim fpath As String
    Dim wb As Workbook
    Dim ws1 As Worksheet
    Dim wb2 As Workbook
    Dim ws2 As Worksheet
    Dim maxrow1 As Long
    Dim row1 As Long
    Dim row2 As Long
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    fpath = "C:\Users	-tai\OneDrive\デスクトップ\図番\図番転記.xlsx"
    Set wb2 = Nothing
    For Each wb In Workbooks
        If wb.Name = "図番転記.xlsx" Then
            Set wb2 = wb
            Exit For
        End If
    Next
    If wb2 Is Nothing Then
        Set wb2 = Workbooks.Open(fpath)
    End If
    Set ws2 = wb2.Worksheets(1)
    row2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    If ws2.Cells(row2, "A").Value <> "" Then
        row2 = row2 + 1
    End If
    maxrow1 = 500
    For row1 = 13 To maxrow1
        If ws1.Cells(row1, "A").Value = "○" Then
            ws2.Cells(row2, "A").Value = ws1.Cells(row1, "C").Value & ws1.Cells(row1, "E").Value & ws1.Cells(row1, "K").Value & _
            ws1.Cells(row1, "O").Value & ws1.Cells(row1, "S").Value & ws1.Cells(row1, "U").Value & "*"
            ws2.Cells(row2, "B").Value = ws1.Cells(row1, "C").Value & ws1.Cells(row1, "E").Value & ws1.Cells(row1, "K").Value & _
            ws1.Cells(row1, "O").Value & "*"
            row2 = row2 + 1
        End If
    Next
End Sub

tatsumaru77 · Answer

前回のは破棄してください。

Option Explicit

Public Sub 別ファイルへ転記()
    Dim fpath As String
    Dim wb As Workbook
    Dim ws1 As Worksheet
    Dim wb2 As Workbook
    Dim ws2 As Worksheet
    Dim maxrow1 As Long
    Dim row1 As Long
    Dim row2 As Long
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    fpath = "C:\Users	-tai\OneDrive\デスクトップ\図番\図番転記.xlsx"
    fpath = "D:\goo\data9\図番転記.xlsx"
    Set wb2 = Nothing
    For Each wb In Workbooks
        If wb.Name = "図番転記.xlsx" Then
            Set wb2 = wb
            Exit For
        End If
    Next
    If wb2 Is Nothing Then
        Set wb2 = Workbooks.Open(fpath)
    End If
    Set ws2 = wb2.Worksheets(1)
    row2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    If ws2.Cells(row2, "A").Value <> "" Then
        row2 = row2 + 1
    End If
    maxrow1 = 500
    For row1 = 13 To maxrow1
        If ws1.Cells(row1, "A").Value = "○" Then
            ws2.Cells(row2, "A").Value = ws1.Cells(row1, "C").Value & ws1.Cells(row1, "E").Value & ws1.Cells(row1, "K").Value & _
            ws1.Cells(row1, "O").Value & ws1.Cells(row1, "S").Value & ws1.Cells(row1, "U").Value & "*"
            ws2.Cells(row2, "B").Value = ws1.Cells(row1, "C").Value & ws1.Cells(row1, "E").Value & ws1.Cells(row1, "K").Value & _
            ws1.Cells(row1, "O").Value & "*"
            row2 = row2 + 1
        End If
    Next
End Sub

エクセルvbaについて

>If ws1.Cells(row1, "A").Value <> "" Thenに変更しましたが、変わりはないです。

不思議ですね。

>頂いたコ－ドをを実行すると転記される側のファイルが開かれるのですが、>何も転記されません。

追伸：

失礼しました。

前回のは破棄してください。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング