エクセル 合計 集計 削除

いつもお世話になります。またまた質問です。
１　G:Jまでの合計をｋに書く
　　G:Jの行は不定の
２　B1を基準に並べ替え後
　　Range("A1").CurrentRegion.Sort _
Key1:=Range("B1"), _
Order1:=xlAscending, _
Header:=xlYes
　　Application.ScreenUpdating = True
　　データー領域B列の空白を削除
３　B1を基準に集計を実施　方法は合計でフィールドはK
４　集計結果を別seetに移動しkが０の行は削除
　　出来れば＊＊＊集計の”集計”部分を無くした形で表したい　＊＊＊はMAX12桁


よろしくお願いします

No.4 ベストアンサー 回答者： Wendy02 回答日時： 2005/05/02 22:46

前回のコードは、ちょっと記録マクロに近いものです。

以下は、私が以前から利用している方法です。ただ、元が勘違いしていたら、総崩れですが……。
これが、わたし流です。何かの参考になれば幸いです。

Sub ConslidationTech()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim CopyRng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim i As Long
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet3")
Application.ScreenUpdating = False

Sh2.Cells.ClearContents
With Sh1
　　Set CopyRng = .Range("A1").CurrentRegion.Offset(, 1)
　　Set Rng1 = .Range("B1", .Range("B65536").End(xlUp))
　　CopyRng.Offset(1, 9).Resize(CopyRng.Rows.Count - 1, 1).Formula = _
　　"=SUM(RC[-4]:RC[-1])"
　　'
　　Rng1.AdvancedFilter _
　　Action:=xlFilterCopy, _
　　CopyToRange:=Sh2.Range("A1"), Unique:=True
End With
With Sh2
　　.Select
　　Set Rng2 = .Range("A1", Range("A65536").End(xlUp))
　　Rng2.Cells(Rng2.Count).Offset(2).Consolidate Sources:=Array( _
　　　　"'" & Sh1.Name & "'!" & CopyRng.Address(, , xlR1C1), _
　　　　"'" & Sh2.Name & "'!" & Rng2.Address(, , xlR1C1)), _
　　　　 Function:=xlSum, _
　　　　TopRow:=False, LeftColumn:=True, CreateLinks:=False
　　　　
　　Rng2.Cells(Rng2.Count).Offset(2). _
　　　　CurrentRegion.Offset(1, 9).Copy .Range("B2")
　　Rng2.Cells(Rng2.Count).Offset(2). _
　　　　CurrentRegion.ClearContents
　　Sh1.Range("K1").Copy .Range("B1")
　　.Range("A1").Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlYes
　　.Range("B1").Value = Application.Substitute(.Range("B1").Value, "集計", "")
　　For i = Range("B65536").End(xlUp).Row To 2 Step -1
　　 If .Cells(i, 2).Value = 0 Then
　　　 .Cells(i, 2).EntireRow.Delete
　　 End If
　　Next
　　.Range("B65536").End(xlUp).Offset(1).FormulaR1C1 = "=Sum(R2C2:R[-1]C2)"
　　.Range("B65536").End(xlUp).Offset(, -1).Value = "合計:"
　　
End With
　　Set Sh1 = Nothing: Set Sh2 = Nothing: Set CopyRng = Nothing
　　Set Rng1 = Nothing: Set Rng2 = Nothing
　　Application.ScreenUpdating = True
End Sub

この回答へのお礼

ありがとうございます
こちらの方が、完成度高いですしすっきりしていますね。
それと、NO.3では”合計”が残ってしまいました
こちら側のコードを理解できるようにがんばりますのでこれからもよろしくお願いします。

お礼日時：2005/05/03 08:58

No.3 回答者： Wendy02 回答日時： 2005/05/02 22:43

一応完成しました。

的外れでないことを祈ります。
それと、わたし流のマクロの書き方のを次の番号にアップしておきます。

Sub ShukeiTest()
　Dim Rng As Range, Rng2 As Range, c As Range
　Dim myData As Variant
　Dim i As Long, j As Long, k As Long
　Dim WordCount As Integer
　Dim myTmpDATA As String
　Dim Sh1 As Worksheet
　Dim Sh2 As Worksheet
　'ユーザー設定
　Set Sh1 = Worksheets("Sheet1") '集計表
　Set Sh2 = Worksheets("Sheet2") 'コピー先
　'
　Application.ScreenUpdating = False
　With Sh1
　　.Select
　　'1.合計
　　Set Rng = .Range("A1").CurrentRegion
　　Rng.Offset(1, 10).Resize(Rng.Rows.Count - 1, 1).Formula = _
　　"=SUM(RC[-4]:RC[-1])"
　　'2 並べ替え
　　Rng.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlYes
　　'2-1 「集計」
　　Rng.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(11), _
　　Replace:=True, PageBreaks:=False, SummaryBelowData:=True
　　.Outline.ShowLevels RowLevels:=2
　　'3.B1を基準に、Kを収録
　　Set Rng2 = Range("B1", Range("B65536").End(xlUp))
　　ReDim myData(1, 0)
　　For Each c In Rng2
　　　If Not c.EntireRow.Hidden Then
　　　　If Not IsEmpty(c.Value) Then
　　　　　ReDim Preserve myData(1, i)
　　　　　myData(0, i) = c.Value
　　　　　myData(1, i) = c.Offset(, 9).Value
　　　　　i = i + 1
　　　　End If
　　　End If
　　Next c
　　 .Range("A1").CurrentRegion.RemoveSubtotal '集計を戻す
　
　'4.別シートに移動
　End With
　With Sh2
　　.Select
　　.Range("A1").CurrentRegion.ClearContents
　　'集計の文字を削除
　　 .Cells(1, 1).Value = Left$(myData(0, LBound(myData, 2)), 12)
　　 .Cells(1, 2).Value = _
　　 Left$(VBA.Trim(Application.Substitute(myData(1, LBound(myData, 2)), "集計", "")), 12)
　　'集計の貼り付け
　　j = 2 'データは、２行目から
　　For i = LBound(myData, 2) + 1 To UBound(myData, 2)
　　　'+1はフィールド分
　　　If myData(1, i) <> 0 Then
　　　　 myTmpDATA = VBA.Trim(Application.Substitute(myData(0, i), " 計", ""))
　　　　.Cells(j, 1).Value = myTmpDATA
　　　　.Cells(j, 2).Value = myData(1, i)
　　　　j = j + 1
　　　End If
　　Next i
　　　.Cells(j - 1, 2).FormulaR1C1 = "=SUM(R2C2:R[-1]C2)"
　　　.Cells(j - 1, 2).Value = .Cells(j - 1, 2).Value
　End With
　Application.ScreenUpdating = True
　Set Rng = Nothing: Set Rng2 = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub

No.2 回答者： Wendy02 回答日時： 2005/05/02 19:41

少し、確認させてください。

＞また、Ｂ列の名称部分は何も記入されない状態でした
えっ！、入れるのですか。気が付きませんでしたわ^^;

＞３　B1を基準に集計を実施　方法は合計でフィールドはK
それから、コマンドの「集計」ですね。それは分からなかったです。

ただ、「集計」は、Excelの一般操作範囲のものですから、本来、Consolidateのほうが、テクニックが少なくて済みます。

転送先では、
K列の
例えば、
ghij横計集計　は、→ghij横計 となると解してよいのですか？
A列の項目（元は、B列)は、「○○ 計」となるところが、以下のように「計」の文字がなくなってよろしいのですか？

A列　　　　　　　B列
フィールド名　　ghij横計
K　　　　　　　　131
J　　　　　　　　111
I　　　　　　　　　65
G　　　　　　　　158
F　　　　　　　　129
E　　　　　　　　193
D　　　　　　　　-26
C　　　　　　　　111
A　　　　　　　　135
総計　　　　　　1240

この回答への補足

ありがとうございます。やはり質問方法が分かりにくいみたいで申し訳ありません。
Ｂ列Ｇ列Ｈ列Ｉ列Ｊ列Ｋ列
A 0046046
A 0038038
A　合計84
となった時にSEET2に結果としてA,84となればよいのですが

補足日時：2005/05/02 20:14

No.1 回答者： Wendy02 回答日時： 2005/05/02 14:13

hou66さん、こんにちは。

細かい部分に不明な点もあるので、不安が残りますが、お書きになった内容を、忠実に再現したつもりです。できれば、一応、完結しなくても、もう少しきちんとしたコードを載せてご質問されたほうがよいと思います。

合計は、
"=SUM(RC[-9]:RC[-1])"　'B列からJ列？
' "=SUM(RC[-8]:RC[-1])"　 'C列からJ列？合計を出す範囲が不明..

Sub ShukeiTest()
　Dim Rng As Range
　Dim myData As Variant
　Dim i As Long, j As Long
　Dim WordCount As Integer
　Dim Sh1 As Worksheet
　Dim Sh2 As Worksheet
　'ユーザー設定
　Set Sh1 = Worksheets("Sheet1") '集計表
　Set Sh2 = Worksheets("Sheet2") 'コピー先
　'
　Application.ScreenUpdating = False
　With Sh1
　　.Select
　　'1.合計
　　Set Rng = .Range("A1").CurrentRegion
　　Rng.Offset(1, 10).Resize(Rng.Rows.Count - 1, 1).Formula = _
　　　　　 "=SUM(RC[-9]:RC[-1])"
　　　　　' "=SUM(RC[-8]:RC[-1])" '合計を出す範囲が不明..
　　'2 並べ替え
　　Rng.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes
　　'3.B1を基準に、Kに収録
　　myData = .Range("B1", .Range("B65536").End(xlUp)).Offset(, 9).Value
　　'4.別シートに移動
　End With
　With Sh2
　　.Select
　　'集計の文字を削除
　　WordCount = InStr(myData(LBound(myData, 1), 1), "集計")
　　If WordCount > 0 Then
　　　.Cells(1, 1).Value = Left$(Mid(myData(LBound(myData, 1), 1), _
　　　　 1, WordCount - 1), 12)
　　　Else
　　　.Cells(1, 1).Value = Left$(myData(LBound(myData, 1), 1), 12)
　　End If
　　'0を抜いた集計の貼り付け
　　j = 2 'データは、２行目から
　　For i = LBound(myData, 1) + 1 To UBound(myData, 1)
　　　'+1はフィールド分
　　If myData(i, 1) <> 0 Then
　　　.Cells(j, 1).Value = myData(i, 1)
　　　j = j + 1
　　End If
　　Next i
　End With
　Application.ScreenUpdating = True
　Set Rng = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub

この回答への補足

いつも素早い対応ありがとうございます。
合計の部分はＧ列からですので
"=SUM(RC[-4]:RC[-1])"
としました。
並べ替えの部分はxlAscendingからxlDescendingに変更しました。
その後集計を行うために
'2-1 集計
Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(11), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
としました。

その後の部分がよく分からないのですが・・・
SEET２の結果としては集計した結果とその元データーがダブって記入されている形となりました。
また、Ｂ列の名称部分は何も記入されない状態でした

補足日時：2005/05/02 16:50