エクセル マクロについての質問です m__m

どなたかお教え下さい！！


エクセルファイル＜名前は都度変わる＞
ファイル内シート複数（約40-50）＜名前は都度変わりバラバラ＞
　
・AからN列までﾃﾞｰﾀが入っている　E：色々な文字　F～N：数字
・1行目は項目名で2行目から約4.5千行まで続いている

以上のようなファイルがあります。

複数あるシート全てに以下のように起動させたいです。

1、F列をR列へ移動　　G列をQ列へ移動　　N列をT列へ移動　　L列をP列へ移動
2、P列×（ｶｹﾙ）H列をO列へ反映　　 M列×（ｶｹﾙ）H列をL列へ反映　
3、E列の最初の半角3文字を対象として全行の小計を出す 　
　　最初の3文字は必ず　”00_”（数数ｱﾝﾀﾞｰﾊﾞｰ）の形になります　
　＜対象文字、L,M,O,P,Q,R＞の小計
対象文字とL,M,O,P,Q,R小計行だけを表示する

　　　　　　　起動前

E 　　 F G H I J K L M N
02_B01715紅手 1 900 963 77.04 2000 160 1 1 0
14_B03414ルメ　 1 900 963 77.04 2000 160 1 10 3
99_B04016虹ル 1 1260 　1348 107.84 2800 224 1 2 0
14_C00915ABT 1 1575 　1685 134.8 3500 280 1 0 0
02_C00915C部 2 3420　1829 146.32 3800 304 2 1 0
02_C00915ニプ 2 3420　1829 146.32 3800 304 2 2 0

起動後

E L M O L Q R
02_ 集計 6450 4 8279 5 7740 5
14_ 集計 9630 10 2648 2 2475 2
99_ 集計 2696 2 1348 1 1260 1

のよにしたいです！！
宜しくお願いいたします！！

No.1 回答者： jmuiny 回答日時： 2016/12/29 16:08

対象ブックは固定でないというので選択にしました。

出力はそのブックのSheet2にします。
あらかじめSheet2がないなら追加する処理を入れて下さい。

Sub Sample()
Dim fname As String
Dim wb As Workbook
Dim sh1 As Worksheet, sh2 As Worksheet
Dim i As Long, imax As Long
Dim j As Long
Dim skey As String
Dim gt_tbl(6) As Long
Dim cnt As Integer
fname = Application.GetOpenFilename(FileFilter:="Book ,*.xlsx", MultiSelect:=False)
If fname = "False" Then Exit Sub
Application.ScreenUpdating = False
Set wb = Workbooks.Open(fname)
Set sh1 = wb.Worksheets("Sheet1")
Set sh2 = wb.Worksheets("Sheet2")
With sh1
imax = .Cells(Rows.Count, "E").End(xlUp).Row
.Range("A1:N" & imax).Copy Destination:=sh2.Range("A1")
End With
With sh2
'ソートして計算
.Range("A2:N" & imax).Sort Key1:=.Range("E2"), order1:=xlAscending
.Range("F2:F" & imax).Cut Destination:=.Range("R2")
.Range("G2:G" & imax).Cut Destination:=.Range("Q2")
.Range("L2:L" & imax).Cut Destination:=.Range("P2")
For i = 2 To imax
.Range("O" & i).Value = .Range("P" & i).Value * .Range("H" & i).Value
.Range("L" & i).Value = .Range("M" & i).Value * .Range("H" & i).Value
Next i
.Range("H2:K" & imax).Clear
'集計
skey = Left(.Range("E2").Value, 3)
j = imax
For i = 2 To imax
Do Until Left(.Range("E" & i).Value, 3) <> skey Or i > imax
For cnt = 0 To 6
gt_tbl(cnt) = gt_tbl(cnt) + .Cells(i, cnt + 12).Value
Next cnt
i = i + 1
Loop
'小計書き出し
j = j + 1
.Range("E" & j).Value = skey & "集計"
For cnt = 0 To 6
If cnt <> 2 Then
.Cells(j, cnt + 12).Value = gt_tbl(cnt)
End If
Next cnt
skey = Left(.Range("E" & i).Value, 3)
For cnt = 0 To 6
gt_tbl(cnt) = .Cells(i, cnt + 12).Value
Next cnt
Next i
j = j + 1
.Range("E" & j).Value = skey & "集計"
For cnt = 0 To 6
If cnt <> 2 Then
.Cells(j, cnt + 12).Value = gt_tbl(cnt)
End If
Next cnt
.Rows("2:" & imax).Delete
End With
wb.Close SaveChanges:=True
Application.ScreenUpdating = True
End Sub

この回答へのお礼

ありがとうございます！　すみません！　
起動はするのですがSheet2に反映されないようでしたTT

お礼日時：2016/12/29 20:14

No.2 回答者： jmuiny 回答日時： 2016/12/29 22:32

何かエラーは出ますか？

出るならどこで、何のエラーか書いて下さい。

それから、対象ブックにSheet2はありますか？
このマクロが入っているブックではなく、対象ブック（ダイアログで選択したもの）のSheet2の結果が出るように作成してあります。

こちらでは、貴方が示した通りのデータを入れて、結果も正しいので出来ないとだけ書かれても、対応できないのですが。

この回答へのお礼

すみません！　説明不足でしたm_ _m
どうもこちらの

If fname = "False" Then Exit Sub
Application.ScreenUpdating = False
Set wb = Workbooks.Open(fname)
Set sh1 = wb.Worksheets("Sheet1")
Set sh2 = wb.Worksheets("Sheet2")

Sheet1　を該当シート名に替えたところ起動いたしました！！

何度も質問で恐縮なのですが、こちらのバラバラのシート名50シート程あるのですがこれを一回で同じ作業を繰返して同ファイルに反映するのは難しいでしょうか。　　度々申し訳ございませんが宜しくお願いいたしますm_ _m

お礼日時：2016/12/31 13:56

No.3 回答者： jmuiny 回答日時： 2016/12/31 14:47

>こちらのバラバラのシート名50シート程あるのですがこれを一回で同じ作業を繰返して

どういう意味ですか？

沢山のシートに対して同じ事をするという事でしょうか？
だとししたらシートはどうしたらいいのでしょう。

こちらの方法はSheet1をSheet2にする方法です。
複数のシートだと、結果シートも同じ数必要になります。

シート名で時間がかかっているようですので、実際のシート名（複数という事なので、2つか3つでもいいです）を書いて下さい。
結果はどのシートに表示したらいいのかも記載して下さい。

この回答へのお礼

ご連絡ありがとうございます！
はい、おっしゃる通りで沢山のシートに対して同じ作業を繰り返したいと考えております。
実際のシートは＜０１６西宮＞＜８１２札幌＞＜堺９９４０＞＜ＢＢＣロス＞＜ソウルＫＲＢ＞など纏りの無いシートが並んでおりシートの項目は全て同じ条件（はじめの列順）で並んでおります。　
実行前＜０１６西宮＞の結果を＜０１６西宮＞に反映（実行前と同じシートに反映さす）　　
実行前＜８１２札幌＞の結果を＜８１２札幌＞に反映（実行前と同じシートに反映さす）
・
・
・
全てのシートに同じ作業を繰り返し同じシートに反映できればと考えております　
宜しくお願いいたします。

お礼日時：2016/12/31 16:15

No.4 ベストアンサー 回答者： jmuiny 回答日時： 2016/12/31 19:34

同一ブックへ上書きは無理です。

新規ブックを出力します。名前は該当ブックの名前に「new_」をつけました。
これ以上の仕様変更は別質問にして下さい。

Sub Sample2()
Dim fname As String
Dim wb1 As Workbook, wb2 As Workbook
Dim sh1 As Worksheet, sh2 As Worksheet
Dim scnt As Integer
Dim i As Long, imax As Long
Dim j As Long
Dim skey As String
Dim gt_tbl(6) As Long
Dim cnt As Integer
fname = Application.GetOpenFilename(FileFilter:="Book ,*.xlsx", MultiSelect:=False)
If fname = "False" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb1 = Workbooks.Open(fname)
Set wb2 = Workbooks.Add
For scnt = 1 To wb1.Worksheets.Count
Set sh1 = wb1.Worksheets(scnt)
With sh1
.Copy After:=wb2.Worksheets(Worksheets.Count)
Set sh2 = wb2.Worksheets(wb2.Worksheets.Count)
imax = .Cells(Rows.Count, "E").End(xlUp).Row
End With
With sh2
'ソートして計算
.Range("A2:N" & imax).Sort Key1:=.Range("E2"), order1:=xlAscending
.Range("F2:F" & imax).Cut Destination:=.Range("R2")
.Range("G2:G" & imax).Cut Destination:=.Range("Q2")
.Range("L2:L" & imax).Cut Destination:=.Range("P2")
For i = 2 To imax
.Range("O" & i).Value = .Range("P" & i).Value * .Range("H" & i).Value
.Range("L" & i).Value = .Range("M" & i).Value * .Range("H" & i).Value
Next i
.Range("H2:K" & imax).Clear
'集計
skey = Left(.Range("E2").Value, 3)
j = imax
For i = 2 To imax
Do Until Left(.Range("E" & i).Value, 3) <> skey Or i > imax
For cnt = 0 To 6
gt_tbl(cnt) = gt_tbl(cnt) + .Cells(i, cnt + 12).Value
Next cnt
i = i + 1
Loop
'計OUTPUT
j = j + 1
sh2.Range("E" & j).Value = skey & "集計"
For cnt = 0 To 6
If cnt <> 2 Then
sh2.Cells(j, cnt + 12).Value = gt_tbl(cnt)
End If
Next cnt
skey = Left(.Range("E" & i).Value, 3)
For cnt = 0 To 6
gt_tbl(cnt) = .Cells(i, cnt + 12).Value
Next cnt
Next i
'最後の計OUTPUT 最後一つの時だけ
If gt_tbl(0) = .Range("L" & imax) Then
j = j + 1
.Range("E" & j).Value = skey & "集計"
For cnt = 0 To 6
If cnt <> 2 Then
.Cells(j, cnt + 12).Value = gt_tbl(cnt)
End If
Next cnt
End If
'明細削除
.Rows("2:" & imax).Delete
End With
Next scnt
With wb2
For scnt = .Worksheets.Count To 1 Step -1
If Left(.Worksheets(scnt).Name, 5) = "Sheet" Then
.Worksheets(scnt).Delete
End If
Next scnt
End With
wb2.SaveAs Filename:=wb1.Path & "\new_" & wb1.Name
wb2.Close
wb1.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

この回答へのお礼

ありがとうございますm(._.)m とても助かりました！！ 色々とわがままを盛り込んで頂きましてありがとうございました‼︎

お礼日時：2016/12/31 22:13