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

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『VBAを 繰り返す方法』(ROCK)

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

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

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

< 使用 Excel:Excel2013、使用 OS:Windows10 >


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

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

(もこな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


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

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.