マクロマクロマクロ

ぱっと見、マグロに見えるおいしそうなタイトルになってしまった

いえ。

エクセルです


VBAです。マクロです。

元プログラマーだから誰かが書いてたやつの修正はできた。(多少)

新規でかくってむずい。

料理に例えると、
出来上がった料理に調味料足すのと、
材料から用意して一から作る。ぐらい違う

と言うわけで書いていたのは、
ファイルの中身を、集計シートにまとめるマクロ
今日はそのメモを貼り付けたかっただけ。

明日からはコーチングとか、心理学とかを綴っていきますよっと。
 

Sub D連携_集計()
'
' D連携_集計 Macro
'

'　ファイルを開いて入力データをコピーする処理
    Dim dIn As Workbooks
    
'貼り付け元のファイルパス
    Dim filePath(5) As String
    filePath(0) = Range("D2").Value & "\" & Range("E2").Value
    filePath(1) = Range("D3").Value & "\" & Range("E3").Value
    filePath(2) = Range("D4").Value & "\" & Range("E4").Value
    filePath(3) = Range("D5").Value & "\" & Range("E5").Value
    filePath(4) = Range("D6").Value & "\" & Range("E6").Value

'貼り付け先のシート名
    Dim sheetName(5) As String
    sheetName(0) = "d_In"
    sheetName(1) = "d_web"
    sheetName(2) = "d_In"
    sheetName(3) = "d_In"
    sheetName(4) = "d_In"

    
    Dim itiranPath As String
    itiranPath = Range("D9").Value & "\" & Range("E9").Value
    
    Dim lastRow As Long
    Dim arrInt As Integer
    For arrInt = 0 To 4 '配列の要素数分にしたい
        If filePath(arrInt) <> "\" Then '★本当はファイルが存在しなければ。にしたい
            Workbooks.Open Filename:=filePath(arrInt)
        
'★空白行あるとき注意。ファイル閉じない方が確認できてよいかも。
'★無条件にA2にしてよいか？エクスポートミスったら1行目消える

        Range("A2").Select
        Rows(Selection.Row & ":" & Selection.End(xlDown).Row).Select
        Selection.Copy
    
        '　一覧を開いて該当するシートの最終行に張り付け
        '今回張り付けたセルを黄色にする
        
        Workbooks.Open Filename:=itiranPath
        Worksheets(sheetName(arrInt)).Activate
        lastRow = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        Cells.Interior.ColorIndex = xlNone
        Rows(lastRow).PasteSpecial
        Selection.Interior.Color = 65535
        
        End If
    Next arrInt
        
        
    
'　ファイルの保存、クローズについては未対応。問題ないことが確認できてから
' 新設等を判断するセルは集計ファイルに作る
'　特定のセルの情報を張り付けるのも別マクロでする
'
'
'    ActiveWorkbook.Save
'    itiran.Close
End Sub

Sub テスト()
'
' テスト Macro
'

'
Workbooks("Book1").Activate

Dim ws As Worksheet
Set ws = Worksheets(インデックス番号)

    Dim TargetBook As Workbook, i As Long, j As Long
    Set TargetBook = Workbooks.Open("Book2.xlsx")
    ThisWorkbook.Activate
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        For j = 2 To Cells(Rows.Count, 1).End(xlUp).Row
            If Cells(i, 1) = TargetBook.Sheets("Sheet1").Cells(j, 1) Then
                Cells(i, 3) = Cells(i, 2) * TargetBook.Sheets("Sheet1").Cells(j, 2)
                Exit For
            End If
        Next j
    Next i
    TargetBook.Close
End Sub