[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAを 繰り返す方法』(ROCK)
手順
?@既存のもので、Excelファイルを選択すると 全シート(20シートくらい)の、B8〜F8列を 別のシートに、順番に貼り付けするVBAがあります。
(既存)
?Aそのあと、のファイルの決められたシート名で B8〜F8列を ?@のデータの
下に貼り付けたいのですが、 現在?@が終わると 処理完了しました というメッセージBOXが表示になります。
次のエクセルファイルを選びますか というメッセージを表示し、?Aのファイルを選択したら 決められたシート名を指定して ?@と同じ処理をするには どのようなVBAにしたらよいでしょうか。
初心者です。
宜しくお願い致します。
< 使用 Excel:Excel2013、使用 OS:Windows10 >
まずは、そちらをステップ実行してどのような処理をしているかしらべて(理解するようにして)みてはいかがでしょうか?
(もこな2 ) 2020/05/17(日) 14:17
Option Explicit
Sub test() Dim wbTo As String Dim wbFrom As String
MsgBox "始めます" wbTo = ThisWorkbook.FullName
Do With Application.FileDialog(msoFileDialogFilePicker) If Not .Show Then Exit Do wbFrom = .SelectedItems(1) End With MsgBox wbFrom & vbLf & "を" & vbLf & wbTo & vbLf & "に転記しました"
If MsgBox("続ける?", vbYesNo) = vbNo Then Exit Do
Loop
MsgBox "終わります"
End Sub
(マナ) 2020/05/17(日) 14:53
1.既存のもので、Excelファイルを選択すると 全シート(20シートくらい)の、B8〜F8列を 別のシートに、順番に貼り付けするVBAがあります。
(既存)
2.別のファイルの決められたシート名で B8〜F8列を 1のデータの
下に貼り付けたいのですが、 現在1が終わると 処理完了しました というメッセージBOXが表示になります。
次のエクセルファイルを選びますか というメッセージを表示し、2つ目のファイルを選択したら1と同じ処理をするには どのようなVBAにしたらよいでしょうか。
初心者です。
宜しくお願い致します。
以下は 既存のVBAです。
この後 続けますか? Y・N で Yの場合は
いちばん最初のファイルを指定して開く に戻り、Nの場合は、 不要なファイルを閉じて
終了です。
また、このほかに 指定したファイルのすべてのシートではなく、シート名を
指定して コピー 貼付けしたいケースもあります。
一緒に実現は難しいでしょうか。
'ファイルを指定して開く
Dim OpenFileName As String Dim Wb1 As Workbook 'ターゲットシート
OpenFileName = Application.GetOpenFilename("エクセル,*.xls?") If OpenFileName <> "False" Then Set Wb1 = Workbooks.Open(OpenFileName, UpdateLinks, ReadOnly) End If
'ターゲットブックの内容把握
Dim PSU 'ページ数の把握
PSU = Worksheets.Count
Dim i As Long Dim j As Long
Dim P(100) As String Dim sname(100) As String Dim シート名 As String
'シート名の取得
For i = 1 To PSU
シート名 = Worksheets(i).name sname(i) = シート名
Next i
'ターゲットシートからDATAシートコピー
Application.DisplayAlerts = False
For j = 1 To PSU
Wb1.Activate
Sheets(sname(j)).Select Cells.Select Application.CutCopyMode = False Selection.Copy
Next j
' 各データの総覧へのコピー()
Dim DATASU Dim ENDROW Dim STARTEROW Dim CHIKU
ENDROW = Range("B65536").End(xlUp).Row STARTEROW = ENDROW + 2
For j = 1 To PSU
Wb1.Activate
Sheets(sname(j)).Select
Cells.Find(What:="終了", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _ xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _ , MatchByte:=False, SearchFormat:=False).Activate
ENDROW = ActiveCell.Row DATASU = ENDROW - 6 CHIKU = Range("B1")
Range("B8:G" & ENDROW).Select Application.CutCopyMode = False Selection.Copy
ThisWorkbook.Activate Sheets("DATA").Select
Range("B" & ENDROW2 + STARTROW + 3).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False
MsgBox "完了しました"
'不要ファイルを閉じる
Application.DisplayAlerts = False Wb1.Activate
ActiveWorkbook.Saved = False ActiveWorkbook.Close
Application.DisplayAlerts = True
Sheets("メニュー").Select Range("A1").Select
(ROCK) 2020/05/17(日) 15:28
ざっとみましたが、使ってない変数があったり、必要のないSelectやActivateが、たくさんあるようにおもいますので、その辺を整理してから、ステップ実行してみて、どの部分を繰り返せばよいのか考えてみてはいかがでしょうか?
Sub 名もなきマクロ()
'▼変数の宣言 Dim OpenFileName As String Dim Wb1 As Workbook 'ターゲットシート Dim SH As Worksheet Dim 終了セル As Range Dim 最終行 As Long
Stop 'ブレークポイントの代わり
'ファイル(ブック)を指定して開く OpenFileName = Application.GetOpenFilename("エクセル,*.xls?") If OpenFileName <> "False" Then Set Wb1 = Workbooks.Open(OpenFileName) Else Exit Sub End If
'▼開いたブックのシートを巡回 For Each SH In Wb1.Worksheets Set 終了セル = Nothing Set 終了セル = SH.Cells.Find(What:="終了", After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, MatchByte:=False, SearchFormat:=False)
If Not 終了セル Is Nothing Then If 終了セル.Row >= 8 Then With ThisWorkbook.Sheets("DATA") 最終行 = .SpecialCells(xlCellTypeLastCell).Row
SH.Range("B8", SH.Cells(終了セル.Row, "D")).Copy .Cells(最終行 + 1, "B").PasteSpecial Paste:=xlPasteValues End With End If End If
Next SH
'ブックを保存せずに閉じる Wb1.Close False
Sheets("メニュー").Select Range("A1").Select
End Sub
(もこな2 ) 2020/05/17(日) 17:31
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.