[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『範囲指定を可変にしたい』(晴天)
こちらでちょうどやりたい事と似ている表の合体について投稿されていた方の回答を参考に、自分のやりたい事を再現しようと頑張っているのですが、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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.