質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

91.23%

  • VBA

    1180questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

ループしたときの、上書きされていかない空白行の取得の仕方

解決済

回答 1

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 54

vbabeginner

score 13

以前の質問(https://teratail.com/questions/102850)で、
複数のファイルデータをループで一気に取り込む仕組みが理解でき、
そこでまた別の種類の見積りデータを取り込んでみることまでできるようになりました。

しかし、ペーストされた先のシートで、転記元のファイルの次のファイルが、空白行が取得できず、一行ずつずれて取り込まれ、一個前のファイルでペーストしたセルの上に上書きされてしまう現象に陥っています。

例えば、下記で「1個目」のセルたちは、1個目の転記元データが取り込まれたセルです。
その上に2個目の転記元データが2行目から、上書きされて取り込まれてしまいます。

イメージ説明

試してみたこと

'出力する空白セルの指定
Dim pasteCell As Excel.Range
Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "D").End(xlUp).Offset(1)

Dim pasteCell As Excel.Range
Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "D").End(xlleft).Offset(1)
もしくは
Dim pasteCell As Excel.Range
Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "D").End(xlUp).End(xlleft).Offset(1)
としたり、
'転記したら出力行を1行進める
iPasteRow = iPasteRow + 1
を削除してみたりしました。
しかし、自分でコードをいじると、実行したとたんに
エラー1004やエラー6が出てしまいます。

現在の全体のソースコードは下記です。

Sub 見積読込()
    '前提条件

    '- 転記先のシートがこのマクロが書かれいるブックであること

    '転記元ファイルの取得用変数
    Const FILE_PATH = "H:+++++"
    Dim sFileName As String

    '転記元のシートの変数
    Dim copyWb As Excel.Workbook
    Dim copyWs As Excel.Worksheet
    '転記先のシートの変数
    Dim pasteWs As Excel.Worksheet
    '出力行
    Dim iPasteRow As Integer

    '転記先のシートを取得
    'マクロが書かれているブックの、アクティブなシート
    Set pasteWs = Excel.ThisWorkbook.ActiveSheet

    '出力する空白セルの指定
    Dim pasteCell As Excel.Range
    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "D").End(xlUp).Offset(1)

    '出力行を取得(先頭行)
    iPasteRow = pasteCell.Row

    '対象フォルダからExcelファイル名を取得
    sFileName = Dir(FILE_PATH & "\*.xlsx*")
    If sFileName = "" Then
        'フォルダにExcelファイルが1つもない場合は処理終了
        Exit Sub
    End If

    '対象フォルダ内のすべてのExcelファイルをループ処理
    Do
    '転記元ブックをオープン
    Set copyWb = Workbooks.Open(FILE_PATH & "\" & sFileName)
    '転記元シートを取得
    Set copyWs = copyWb.Worksheets(1) '先頭シート

    '除外するものがあればここで条件を指定して転記処理に入れない
        If True = True Then
            '除外するもの以外は転記処理

            '発行日を開いている転記元からコピーして転記先にペースト
            Set pasteCell = pasteWs.Cells(iPasteRow, "A")

            Dim hakkobiCell As Excel.Range
            Set hakkobiCell = copyWs.Range("A6")

            hakkobiCell.Copy
            pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

             '見積番号'を開いている転記元からコピーして転記先にペースト
            Set pasteCell = pasteWs.Cells(iPasteRow, "B")

            Dim quotenoCell As Excel.Range
            Set quotenoCell = copyWs.Range("A7")

            quotenoCell.Copy
            pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

            '品名'を開いている転記元からコピーして転記先にペースト
            Set pasteCell = pasteWs.Cells(iPasteRow, "C")

            Dim hinmeiCell As Excel.Range
             Set hinmeiCell = copyWs.Range("A17")

            hinmeiCell.Copy
            pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False


            '作業内容'を開いている転記元からコピーして転記先にペースト
           Set pasteCell = pasteWs.Cells(iPasteRow, "D")

            Dim sagyoCell As Excel.Range
            With copyWs
                Set sagyoCell = _
                    .Range( _
                        .Range("B38"), _
                    .Range("B38").End(xlDown) _
                )
            End With 'copyWs

            sagyoCell.Copy
            pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

              '数量'を開いている転記元からコピーして転記先にペースト
           Set pasteCell = pasteWs.Cells(iPasteRow, "F")

            Dim suryoCell As Excel.Range
            With copyWs
                Set suryoCell = _
                    .Range( _
                        .Range("J38"), _
                        .Range("J38").End(xlDown) _
                )
            End With 'copyWs

            suryoCell.Copy
            pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

              '単価'を開いている転記元からコピーして転記先にペースト
           Set pasteCell = pasteWs.Cells(iPasteRow, "G")

            Dim tankaCell As Excel.Range
            With copyWs
                Set tankaCell = _
                    .Range( _
                        .Range("L38"), _
                        .Range("L38").End(xlDown) _
                )
            End With 'copyWs

            tankaCell.Copy
            pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False
              '金額'を開いている転記元からコピーして転記先にペースト
           Set pasteCell = pasteWs.Cells(iPasteRow, "H")

            Dim kingakuCell As Excel.Range
            With copyWs
                Set kingakuCell = _
                    .Range( _
                        .Range("M38"), _
                        .Range("M38").End(xlDown) _
                )
            End With 'copyWs

            kingakuCell.Copy
            pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False


            '転記したら出力行を1行進める
            iPasteRow = iPasteRow + 1
        End If

        '転記元ブックを閉じる
        copyWb.Close SaveChanges:=False

        '次のファイル名を取得
        sFileName = Dir

    Loop Until sFileName = ""    'ファイル名が取得できなくなるまで繰り返す

End Sub


理解が遅く、同じような質問ばかりで恐縮ですが、何卒アドバイスいただければ幸いです。
どうぞよろしくお願いいたします。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

checkベストアンサー

0

iPasteRow の値が
処理が進むごとにどのようにどうなっているか
追っていけば自ずとわかると思います。

一時的に
iPasteRow = iPasteRow + 1

iPasteRow = iPasteRow + 5
とかに変えてやるとわかりやすいかもしれないですね。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/01/12 15:22

    早速のご回答ありがとうございます!
    いただいたヒントを元に
    観察してみます!

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

ただいまの回答率

91.23%

関連した質問

同じタグがついた質問を見る

  • VBA

    1180questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。