[[20200517121717]]　『VBAを　繰り返す方法』（ROCK）　ページの最後に飛ぶ

『VBAを　繰り返す方法』（ROCK）

手順
?@既存のもので、Excelファイルを選択すると　全シート（20シートくらい）の、B8～F8列を　別のシートに、順番に貼り付けするVBAがあります。
（既存）

?Aそのあと、のファイルの決められたシート名で　B8～F8列を　?@のデータの
下に貼り付けたいのですが、　現在?@が終わると　処理完了しました　というメッセージBOXが表示になります。

次のエクセルファイルを選びますか　というメッセージを表示し、?Aのファイルを選択したら　決められたシート名を指定して　?@と同じ処理をするには　どのようなVBAにしたらよいでしょうか。
初心者です。
宜しくお願い致します。　

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

残念ながら私の環境だと文字化けしちゃってるけど、
＞VBAがあります。

まずは、そちらをステップ実行してどのような処理をしているかしらべて（理解するようにして）みてはいかがでしょうか？

（もこな２） 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

もこな２様　マナ様　
文字化け大変失礼しました。
丸１　丸２　が文字化けしていました。

１．既存のもので、Excelファイルを選択すると　全シート（20シートくらい）の、B8～F8列を　別のシートに、順番に貼り付けするVBAがあります。
（既存）
２．別のファイルの決められたシート名で　B8～F8列を　１のデータの
下に貼り付けたいのですが、　現在１が終わると　処理完了しました　というメッセージBOXが表示になります。
次のエクセルファイルを選びますか　というメッセージを表示し、２つ目のファイルを選択したら１と同じ処理をするには　どのようなVBAにしたらよいでしょうか。
初心者です。
宜しくお願い致します。　

以下は　既存のVBAです。
この後　　続けますか？　Ｙ・N で　Ｙの場合は　　
いちばん最初のファイルを指定して開く　に戻り、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

（もこな２） 2020/05/17(日) 17:31

コメント返信：

[ 一覧(最新更新順) ]

[[20200517121717]] 『VBAを 繰り返す方法』（ROCK） ページの最後に飛ぶ

[[20200517121717]]　『VBAを　繰り返す方法』（ROCK）　ページの最後に飛ぶ