| |
こちらでご指導いただいたりしながら試行錯誤で
下記のようなマクロを作成しました。
何がしたいかといいますと、H列最終行に入っている合計金額を
新フセルD10に,またF10には=D10×0.8（小数点以下切捨て）の値を
入れたいのですが、
ここがなかなかうまくいきません。
レイアウトは下記の通りです。
[D10]御買上額_________ [F10]ご請求額_________
C列 D列 E列 F列 G列 H列
納品日 種類 品名 値段 個数 金額
2013/4/20 くだもの りんご 200 1 200
2013/4/20 くだもの みかん 580 28 16,240
2013/4/20 野菜 にんじん 580 1 580
2013/4/21 くだもの りんご 580 1 580
2013/4/21 くだもの バナナ 520 1 520
2013/4/23 野菜 大根 300 1 300
2013/4/23 くだもの パイン 150 1 150
合計 18,570
お知恵をお借りできますでしょうか？
宜しくお願い致します。
Sub 1.集計()
'Application.ScreenUpdating = False
ActiveWorkbook.Save
With Worksheets("DB")
.Range("C4").AutoFilter _
Field:=5, Criteria1:=">=1"
.Range("C4").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
Worksheets("集計").Range("a1")
.AutoFilterMode = False
End With
Worksheets("集計").Activate
Columns("A:F").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Sub 2.転記()
Dim v As Variant
Dim z As Long
Dim i As Long
Dim k As Long
Dim dic As Object
Dim dKey As String
Dim c As Range
Dim w As Variant
Dim y As Long '★追加
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("集計")
z = .Range("A1").CurrentRegion.Rows.Count - 1
ReDim v(1 To z, 1 To 6)
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
dKey = Join(WorksheetFunction.Index(c.Resize(, 4).Value, 1, 0), vbTab)
If Not dic.exists(dKey) Then
dic(dKey) = dic.Count + 1
i = dic(dKey)
v(i, 1) = c.Value
v(i, 2) = c.Offset(, 1).Value
v(i, 3) = c.Offset(, 2).Value
v(i, 4) = c.Offset(, 3).Value
End If
i = dic(dKey)
v(i, 5) = v(i, 5) + c.Offset(, 4).Value
v(i, 6) = v(i, 6) + c.Offset(, 5).Value
Next
End With
With Sheets("請求書")
'請求書シートの使用済みの最終行 取得
y = .UsedRange.Cells(.UsedRange.Cells.Count).Row '★追加
If y > 11 Then .Rows("12:" & y).ClearContents '★変更12行目以下にデータが入っていれば削除
.Range("C12:H12").Value = Sheets("集計").Range("A1:F1").Value
.Range("C13").Resize(dic.Count, 6).Value = v
'★以下の行、レイアウト変更
.Rows(13).Resize(dic.Count).Sort Key1:=.Range("C12"), Order1:=xlAscending, Header:=xlNo
.Range("C12").Offset(dic.Count + 1).Value = "合計"
.Range("H12").Offset(dic.Count + 1).FormulaR1C1 = "=SUM(R2C:R[-1]C)"
'============ 罫線他の書式設定 開始
.Cells.Borders.LineStyle = xlNone 'すでにひかれている罫線があればそれを削除
'1行目 タイトル行 ★あらかじめ書式設定しておけば、コード処理は不要
With .Range("C12:H12")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
'合計行
With .Range("C12").Offset(dic.Count + 1)
.Resize(, 5).HorizontalAlignment = xlCenterAcrossSelection
.Offset(, 5).HorizontalAlignment = xlRight
.Resize(, 5).VerticalAlignment = xlCenter
End With
'データ領域
With .Range("C13").Resize(dic.Count, 3)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With .Range("F13").Resize(dic.Count, 3)
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
End With
'桁区切りカンマ
With .Range("C12:H12")
Selection.Style = "Comma [0]"
End With
'新罫線
With .Range("C10:H10").Borders '大ﾀｲﾄﾙ
.LineStyle = xlContinuous
.Weight = xlThin
End With
'罫線
With .Range("C12:H12").Resize(dic.Count + 2).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
'★これは、あらかじめ書式設定しておけばコード処理は不要
'.Columns("C:H").EntireColumn.AutoFit
'============ 罫線他の書式設定 終了
.Select
End With
Application.ScreenUpdating = True
'ActiveWorkbook.Save
Set dic = Nothing
MsgBox "合計処理完了"
End Sub
|
|
たくまよ
- 13/6/20(木) 11:54 -
