Excel VBAで作成するにあたって、画像上部の元データを

質問

Excel VBAで作成するにあたって、画像上部の元データを
画像下部のように行列位の違いがあるような項目に
データを抽出して転記するにはどうしたらよいでしょうか？

手順
・支店ごとにデータを抽出し、シート名を付ける
・データを担当者ごとに1行に集約して転記する

VBA初心者で勉強中ですが大変困難です。
どなたか教えてください。よろしくおねがいいたします。

回答No.2

kmetu · ベストアンサー

Sheets(.Range("J" & i).Value).Range("B" & Sheets(.Range("J" & i).Value).Range("B" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Next

End With

Application.DisplayAlerts = False
Sheets("mTemp").Delete
Application.DisplayAlerts = True

ANo1とこれを引っ付けてください。
備考欄はどのような考えなのか分からなかった
(ケースとないもないところがあり　ケースを選択してるようだけどケース以外に何かあった場合どうするのかわからない)
ので対応していません。

mTempというシートを作成して作業をしますから同じ名前のシートが既にある場合エラーになります。

実行は画像で示されたシートを表示した状態で実行してください。

お礼

本当にありがとうございました。感謝いたします。

回答No.1

kmetu

Dim mMatch As Boolean

ActiveSheet.Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "mTemp"
With Sheets("mTemp")
.Range("B1:E11").Select
.Range("B1:E11").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("J1"), Unique:=True
.Range("N1").Value = "りんご"
.Range("O1").Value = "バナナ"
.Range("P1").Value = "みかん"
.Range("Q1").Value = "合計"
.Range("R1").Value = "備考"
.Range("N2").FormulaR1C1 = "=SUMPRODUCT((R2C2:R11C2=RC10)*(R2C3:R11C3=RC11)*(R2C5:R11C5=RC13)*(R2C6:R11C6=R1C)*(R2C7:R11C7))"
.Range("N2").AutoFill Destination:=.Range("N2:N5"), Type:=xlFillDefault
.Range("N2:N5").AutoFill Destination:=.Range("N2:P5"), Type:=xlFillDefault
.Range("Q2").FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
.Range("Q2").AutoFill Destination:=.Range("Q2:Q5"), Type:=xlFillDefault

For i = 2 To .Range("J" & Rows.Count).End(xlUp).Row
mMatch = False
For Each sh In ActiveWorkbook.Worksheets
If sh.Name = .Range("J" & i).Value Then
mMatch = True
End If
Next
If mMatch = True Then
Sheets(.Range("J" & i).Value).Range("A" & Sheets(.Range("J" & i).Value).Range("B" & Rows.Count).End(xlUp).Row + 1).Value = _
Sheets(.Range("J" & i).Value).Range("B" & Rows.Count).End(xlUp).Row
.Range("J" & i & ":R" & i).Copy
Else
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = .Range("J" & i).Value
Sheets(.Range("J" & i).Value).Range("A1").Value = "No."
Sheets(.Range("J" & i).Value).Range("A2").Value = 1
.Range("J1:R1").Copy
Sheets(.Range("J" & i).Value).Range("B1").PasteSpecial Paste:=xlValues
.Range("J" & i & ":R" & i).Copy
End If

お礼

本当にありがとうございました。心から感謝いたします。