[[20211123124058]]　『範囲指定を可変にしたい』（晴天）　ページの最後に飛ぶ

『範囲指定を可変にしたい』（晴天）

こちらでちょうどやりたい事と似ている表の合体について投稿されていた方の回答を参考に、自分のやりたい事を再現しようと頑張っているのですが、2点分からないので質問させてください。

やりたい事は、マクロファイル（開いている）、転記元ファイル、転記先のファイルの3ファイル存在し、転記元の表の項目行を除いた行を転記先のファイルにコピーしたいのですが、転記元には転記先にはない列があるので、
該当列のみをコピーして貼り付けるマクロを考えています。

正しく動くのですが、二点お聞きしたい事があります。
1. 本来の使い方はマクロファイルのみ開いている事を想定していますが、
仮に、転記元ファイル、転記先ファイルも開いた状態からスタートしてしまうと結果が正しく表示されません。（デバックで変数の内容を見ると、参照先が転記元ファイルのみ選択しているよう？です。）
なぜだか分かりますでしょうか。

2. 今は転記元のコピーしたい列番号をB列、D列、F～I列と直接入力していますが、そこを可変にしたいです。
マクロファイルのセルA1に「B3:B」、セルA2に「D3:D」、セルA3に「F3:I」と
書いておいてそこを読み込むように出来ないか…とか、
でも組み合わせが3セルで済まない場合はコードの方も変更しないといけないのか…等色々ネットで調べてみてもどのように書けばいいのか分かりません。
ご教授頂ければ幸いです。

今出来ているコードは、下記のようになっています。

Sub 転記元ファイルの指定列を転記先へ合体()

 Dim path As String
 Dim 元 As String
 Dim 先 As String
 Dim macro As Workbook
 Dim wb元 As Workbook
 Dim wb先 As Workbook

 path = ThisWorkbook.path & "\"
 元 = Dir(path & "元データ.xlsm")
 先 = Dir(path & "合体先.xlsx")
 Set macro = ThisWorkbook
 Set wb元 = Workbooks.Open(path & 元)
 Set wb先 = Workbooks.Open(path & 先)

 Dim LastRowmoto As Long
 LastRowmoto = wb元.Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row

 Dim LastRowsaki As Long
 LastRowsaki = wb先.Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row

 wb元.Sheets("sheet1").Range("B3:B" & LastRowmoto & ",D3:D" & LastRowmoto & ",F3:I" & LastRowmoto).Copy wb先.Sheets("sheet1").Range("B" & LastRowsaki + 1)

End Sub

＜使用 Excel：Excel2010、使用 OS：unknown ＞

 マクロファイルのセルA1に「B3:B」、セルA2に「D3:D」、セルA3に「F3:I」と書いてあるとして
 以下、一例です。適宜修正して下さい。
 ※マクロファイルのA列に記述するエリアを増やす場合、空白行を入れない様（CurrentRegionを用いているので）
 ※提示例ではB列最下行が基準になっているようなので、それに準じています。
 要点はエリアの番地を配列に入れて順に処理するということです。

 ＞転記元には転記先にはない列があるので
 大変失礼しました。上記条件を完全に失念していました。
 以下訂正したものに差替えました。2021/11/23 16:29

 Sub Macro1()
    Dim wb元 As Worksheet
    Dim wb先 As Worksheet
    Dim LastRowmoto As Long, LastRowsaki As Long
    Dim arr, var
    Dim i As Long
    Dim col As String
    Dim rng As Range

    Set wb元 = Workbooks.Open(ThisWorkbook.path & "\元データ.xlsm").Worksheets("sheet1")
    Set wb先 = Workbooks.Open(ThisWorkbook.path & "\合体先.xlsx").Worksheets("sheet1")
    arr = ThisWorkbook.Worksheets("sheet1").Cells(1, 1).CurrentRegion.Value
    LastRowsaki = wb先.Cells(Rows.Count, "B").End(xlUp).Offset(1).Row '必ず合体先B列の最下行になる
    For Each var In arr
        For i = 1 To Len(var)
            If IsNumeric(Mid(var, i, 1)) Then Exit For
        Next i
        col = Left(var, i - 1)
        LastRowmoto = wb元.Range(col & Rows.Count).End(xlUp).Row
        If rng Is Nothing Then
            Set rng = wb元.Range(var & LastRowmoto)
        Else
            Set rng = Union(rng, wb元.Range(var & LastRowmoto))
        End If
    Next var
    rng.Copy wb先.Cells(LastRowsaki, "B")
 End Sub
（カレーうどん） 2021/11/23(火) 14:27

 >仮に、転記元ファイル、転記先ファイルも開いた状態からスタートしてしまうと結果
 開いていなければ開くようにしました。

 >今は転記元のコピーしたい列番号をB列、D列、F～I列と直接入力していますが、
 >そこを可変にしたいです。
 InputBoxを設けましたので転記する列を選択してください(離れた列はCtrlキーを使ってください)

 Sub 転記元ファイルの指定列を転記先へ合体2()
    Dim path As String
    Dim 元 As String
    Dim 先 As String
    Dim macro As Workbook
    Dim wb元 As Workbook
    Dim wb先 As Workbook
    Dim myCell As Range

    On Error Resume Next
    Set wb元 = Workbooks("元データ.xlsm")
    If Err Then
        '元データ.xlsmが開いていないなら開く
        Set wb元 = Workbooks.Open(ThisWorkbook.path & "\元データ.xlsm")
        Err.Clear
    End If
    Set wb先 = Workbooks("合体先.xlsx")
    If Err Then
        '合体先.xlsxが開いていないなら開く
        Set wb先 = Workbooks.Open(ThisWorkbook.path & "\合体先.xlsx")
        Err.Clear
    End If
    On Error GoTo 0
    Dim LastRowmoto As Long
    LastRowmoto = wb元.Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row
    Dim LastRowsaki As Long
    LastRowsaki = wb先.Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row
    wb元.Activate
    On Error Resume Next
    Set myCell = Application.InputBox(prompt:="転記する列(A･B･C･･)を[Ctrl]キーを使って選択してください。" _
            & vbCrLf & "例) B [Ctrl] D [Ctrl] F [Ctrl]", Type:=8)
    If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0
    Set myCell = Intersect(myCell, Range("A3:A" & LastRowmoto).EntireRow)
    myCell.Copy wb先.Sheets("sheet1").Cells(LastRowsaki + 1, "B")
    wb先.Activate
 End Sub

（ピンク） 2021/11/23(火) 15:16

カレーうどん様、ピンク様
大変ありがとうございます。教えて頂いたコード、どちらもやりたい事を再現できました。

カレーうどん様のコードは、デバックで一つずつ意味を理解しようとトライしていますが、
配列の勉強がまだ出来ておらず完全理解には至っていませんが、今後色々覚えたら活用できそうなコードが満載で、引き続き勉強してみます。ありがとうございます。

ピンク様のInputBoxを使って指定後にSet myCell = Intersect(myCell, Range("A3:A" & LastRowmoto).EntireRow)とする…。なるほどですね！
また、ファイルが開いていたら…の指定方法も、ずっと疑問に思っていた事だったので、大変勉強になりました。ありがとうございます。

あと、お二方ともWorkbookの取得を、下記1行で書かれていて、私のは無駄が多すぎですね。。今後、このような書き方活用させて頂きます。
Set wb元 = Workbooks.Open(ThisWorkbook.path & "\元データ.xlsm").Worksheets("sheet1")

ご親切に、ありがとうございました！！

（晴天） 2021/11/23(火) 18:08

コメント返信：

[ 一覧(最新更新順) ]

[[20211123124058]] 『範囲指定を可変にしたい』（晴天） ページの最後に飛ぶ

[[20211123124058]]　『範囲指定を可変にしたい』（晴天）　ページの最後に飛ぶ