VBA 貼り付け 上書きされてしまう

Question

以下はフォルダを選択してフォルダの直下にある全てのファイルのデータを貼り付けるコードです。
2回目(実行を2回目)から、貼り付ける時に、すでにデータが貼り付けられているセルの上から再度貼り付けてしまいます。
例） A2にRubyという文字が入っているが、再度貼り付け処理を行うとA2がPHPになってしまう。
そうではなく、再度貼り付けたときはA2はPHP,A3にRubyというように、貼り付けたデータの数ぶんだけ、すでにあるデータを下にずらしたいです。
よろしくお願いいたします。

Sub Code()

Application.DisplayAlerts = False


Dim Filename    As String
Dim IsBookOpen  As Boolean
Dim OpenBook    As Workbook
Dim myFolder As Variant
Dim file() As Variant
Dim target_sheet As Worksheet
Dim target_sheet2 As Worksheet
Dim open_file

d = 0
e = 1
g = 0

'フォルダの直下のファイルを取ってくる処理
Button = MsgBox("貼り付けを行いますか", vbYesNo + vbQuestion, "確認")

  If Button = vbYes Then

    With Application.FileDialog(msoFileDialogFolderPicker)

    If .Show <> 0 Then
    
        myFolder = .SelectedItems(1)
        
    End If
 
   End With


With CreateObject("WScript.Shell")
    
    .CurrentDirectory = myFolder
    
End With

Filename = Dir("*画面.xls*")
     
Do While Filename <> ""
    
    If Filename <> ThisWorkbook.Name Then
    
        IsBookOpen = False
        
        For Each OpenBook In Workbooks
                    
            If OpenBook.Name = Filename Then
            
                IsBookOpen = True
                
                Exit For
            Else
            
            End If
            
        Next
        
        If IsBookOpen = False Then
            ReDim Preserve file(d)
            file(d) = Filename
            d = d + 1
            
        End If
        
    End If
    Filename = Dir()
    
Loop

  Else
    MsgBox "ファイルは存在しません"
    
Exit Sub
    
End If


If d > 0 Then 'フォルダの直下に指定されているファイルがあるなら実行するという条件になります

a = 2
Do While UBound(file) >= g

Application.ScreenUpdating = False

file_name = file(g) 'ファイルの名前
Filename = Dir(myFolder & "\" & file_name)


Set open_file = Workbooks.Open(Filename:=myFolder & "\" & Filename, UpdateLinks:=False)
 
Set target_sheet = Workbooks(Filename).Worksheets("説明")
Set target_sheet2 = ThisWorkbook.Worksheets("テスト")

maxRow = target_sheet.Cells(Rows.Count, 2).End(xlUp).Row 

'配列の定義
ReDim screen(1, 1 To maxRow)
ReDim Number(1, 1 To maxRow)
ReDim Lavel(1, 1 To maxRow)
ReDim Project_type(1, 1 To maxRow)
ReDim Control(1, 1 To maxRow)
ReDim Events(1, 1 To maxRow)
ReDim Sort(1, 1 To maxRow)
ReDim Lifting(1, 1 To maxRow)
ReDim Erea(1, 1 To maxRow)

l = 8
c = 1

'貼り付けたいデータを配列に格納
For i = 1 To UBound(screen, 1)
  For f = 1 To maxRow
    screen(i, f) = target_sheet.Cells(l, 4)
    Number(i, f) = target_sheet.Cells(l, 2)
    Lavel(i, f) = target_sheet.Cells(l, 14)
    Project_type(i, f) = target_sheet.Cells(l, 10)
    Control(i, f) = target_sheet.Cells(l, 32)
    Events(i, f) = target_sheet.Cells(l, 81)
    Sort(i, f) = target_sheet.Cells(l, 85)
    Lifting(i, f) = target_sheet.Cells(l, 87)
    
    If TypeName(target_sheet.Cells(l, 2).Value) = "String" Then
    Erea(i, c) = target_sheet.Cells(l, 2)
    c = c + 1
    End If
    
    l = l + 2
    
    Next f
Next i



b = 1
For i = 1 To UBound(screen, 1)
l = 8
  For f = 1 To maxRow


'ここで配列の中にあるデータを貼り付け
    If IsNumeric(target_sheet.Cells(l, 2).Value) = True And target_sheet.Cells(l, 2) <> "" Then 
    
    target_sheet2.Cells(a, 6) = CStr(screen(i, f))
    target_sheet2.Cells(a, 2) = Workbooks(Filename).Worksheets("???").Cells(16, 25)
    target_sheet2.Cells(a, 3) = Workbooks(Filename).Worksheets("???").Cells(17, 25)
    target_sheet2.Cells(a, 5) = Number(i, f)
    target_sheet2.Cells(a, 7) = CStr(Lavel(i, f))
    target_sheet2.Cells(a, 8) = CStr(Project_type(i, f))
    target_sheet2.Cells(a, 9) = CStr(Control(i, f))
    target_sheet2.Cells(a, 10) = CStr(Events(i, f))
    target_sheet2.Cells(a, 11) = Sort(i, f)
    target_sheet2.Cells(a, 12) = Lifting(i, f)
    target_sheet2.Cells(a, 4) = Erea(i, f)
    a = a + 1
    End If
    
    l = l + 2

  Next f
Next i
Workbooks(Filename).Close
g = g + 1 '次のファイルを貼り付ける

Application.ScreenUpdating = True
Loop

Else
 MsgBox "ファイルは存在しません"
 
End If

End Sub

Comments

[meg_]

行番号の指定がおかしいんだとは思いますが、具体的なことはデバックして確認してみてください。※ファイル毎にtarget_sheet2の最終セル行+1を取得すれば良いかと。

[yakumo02]

ありがとうございます！

Answer 1

張り付ける前にそのセルに値が入っているかどうかをチェックし、値が入っていたらセルの挿入か、行の挿入をやるコードを書けばいいです。
挿入がどういうコードになるか分からなければ、excelの「開発」タブ→「マクロの記録」を使えばコードを吐き出してくれます。

ps. ここは無料でコードを作成してもらう所ではありません。作成してもらいたければ、有償でプログラムを作成してくれる業者を探してください。

Comments

[yakumo02]

回答ありがとうございます。
ただ、コードを教えてくれとは書いていませんので、ご理解よろしくお願いします

[sousuke]

であれば「貼り付けたデータの数ぶんだけ、すでにあるデータを下にずらしたい」動作をするためにあなたが書いたコードを提示してください。
それがないなら丸投げで「コードを教えてくれ」ととられてもしかたないので。

Answer 2

貼り付けたデータの数ぶんだけ、すでにあるデータを下にずらしたいです。

貼り付けた分だけだと、すでに上書きされているのでだめではないですか？
プログラムは書いたとおりに動きます。この辺の表現をいい加減に考えているから、
意図したとおりに動かないのでは？

貼り付けるデータ数分、行を挿入。
↓
データの書き込み

という流れですよね？

再確認を。

それから、
行の挿入とかは行数の取得とかいろいろめんどいので、
データに仮で並び順を持たせて、
エクセル君に並び替えさせてはいかがでしょう？
それなら最終行の下にデータを書き込むことでも対処できるるので、
データの書き込み先を難しく考えなくてもいいかと思います。
エクセルのソート機能はなかなか優秀なので、
変にVBAでデータをゴネゴネ弄繰り回すより、
エクセル君に処理を任せられるといいかなと思いました。

あと、2次元配列のセルをたくさん用意しているようですが、
各セルの値を各各読み込んで、
またその値群を各各書き込んでいくと処理が重くなります。
エクセルのシートは、
二次元配列を可視化したものとも考えらます。
そうすると、シートに配置する値の並びのイメージを変数側で作ってやることで、
1行の命令文でシート上に展開することが可能になりますので、
その方向で考えてみてはいかがでしょうか？

また、データの中の一部の列を飛び飛びで抽出したい場合は、
フィルタオプションの機能でできます。
この機能はデータの先頭にタイトル行があることが前提なので、
先頭にタイトル行を追加することで、
コードが簡略化できます。

あと、プロシージャは、他のプロシージャから呼び出すことが可能です。
つまり、1つのファイルで処理できるようにプロシージャを作っておけば、
各ファイルを開くごとにそのプロシージャを呼び出すことで、
既定の処理をすることが可能になります。
なので、まずは1つのファイルでやりたいことができるようになれば、
繰り返すことは簡単なので、まずは確実に1つのファイルについて意図通りに
作業の命令をできるようになってはいかがでしょう？
今のコードでは、だらだらだら、テーマと関係ないことも含めて1つのプロシージャに
書いているので、今回のテーマと問題点がどこにあるか分かりにくくて、
読むきになれません（個人的な意見かも知れませんが）。

なので、とりあえず、

1）データを集積するファイルにすでにデータが記入してある。
2）次の読み込むファイルが既にエクセルで開いてある

という前提条件で作業の流れを考えてみることから始めてみてはいかがでしょうか？

参考になれば。