Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


1440 / 13645 ツリー ←次へ | 前へ→

【74454】最終行の合計をほかのセルへ転記したい。 マヨネーズ 13/6/20(木) 11:20 質問[未読]
【74455】Re:最終行の合計をほかのセルへ転記したい。 UO3 13/6/20(木) 11:35 発言[未読]
【74456】Re:最終行の合計をほかのセルへ転記したい。 たくまよ 13/6/20(木) 11:46 発言[未読]
【74458】Re:最終行の合計をほかのセルへ転記したい。 UO3 13/6/20(木) 13:23 発言[未読]
【74459】Re:最終行の合計をほかのセルへ転記したい。 たくまよ 13/6/20(木) 13:34 発言[未読]
【74457】Re:最終行の合計をほかのセルへ転記したい。 たくまよ 13/6/20(木) 11:54 質問[未読]
【74460】Re:最終行の合計をほかのセルへ転記したい。 UO3 13/6/20(木) 16:12 発言[未読]
【74477】Re:最終行の合計をほかのセルへ転記したい。 たくまよ 13/6/25(火) 14:12 お礼[未読]

【74454】最終行の合計をほかのセルへ転記したい。
質問  マヨネーズ  - 13/6/20(木) 11:20 -

引用なし
パスワード
   こちらでご指導いただいたりしながら試行錯誤で
下記のようなマクロを作成しました。
最終的には新フォーマットのセルD10に請求額合計を
F10には=D10×0.8(小数点以下切捨て)の値を入れたいのですが、
ここがなかなかうまくいきません。
お知恵をお借りできますでしょうか?
宜しくお願い致します。


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

【74455】Re:最終行の合計をほかのセルへ転記した...
発言  UO3  - 13/6/20(木) 11:35 -

引用なし
パスワード
   ▼マヨネーズ さん:

回答ではありません。
マヨネーズさんって たくまよ さんですか?
いずれにしても、コードだけアップしても、回答者の皆さんにとってはつらいものがありますね。
どういうレイアウトで、どんな処理をして、どんな結果にしている。
ということを、ちゃんと書いたうえで、そこに、このような追加をしたい。
こう、もっていかなければ。
(あるいは、それが面倒?だということなら、そのあたりが記述されている【前スレ】のURLを貼っておくとか)

それと、たくまよさんのコードもそうだったんですが、

Sub 1.集計() とか Sub 2.転記() とかいった記述、そちらでは構文エラーにはならないんですか?

【74456】Re:最終行の合計をほかのセルへ転記した...
発言  たくまよ  - 13/6/20(木) 11:46 -

引用なし
パスワード
   ▼UO3 さん:
前回マヨネーズで質問していると思っていました。
はい、ご指摘有難うございます。
もう一度アップしなおします。

>Sub 1.集計() とか Sub 2.転記() とかいった記述、そちらでは構文エラーにはならないんですか?

大丈夫です。

【74457】Re:最終行の合計をほかのセルへ転記した...
質問  たくまよ  - 13/6/20(木) 11:54 -

引用なし
パスワード
   こちらでご指導いただいたりしながら試行錯誤で
下記のようなマクロを作成しました。
何がしたいかといいますと、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

【74458】Re:最終行の合計をほかのセルへ転記した...
発言  UO3  - 13/6/20(木) 13:23 -

引用なし
パスワード
   ▼たくまよ さん:

>>Sub 1.集計() とか Sub 2.転記() とかいった記述、そちらでは構文エラーにはならないんですか?
>
>大丈夫です。

お返事ありがとうございます。
こちら(Win7 xl2010) では構文エラーになりますね。
たくまよさんの環境は? Mac とか?

MSのページでも、プロシジャ名にピリオドは使えないと書いてあります。
また、数字から始まるものもエラーだと書いてありますが?

support.microsoft.com/kb/157532/ja

【74459】Re:最終行の合計をほかのセルへ転記した...
発言  たくまよ  - 13/6/20(木) 13:34 -

引用なし
パスワード
   ▼UO3 さん:
>▼たくまよ さん:
>
>>>Sub 1.集計() とか Sub 2.転記() とかいった記述、そちらでは構文エラーにはならないんですか?
>>
>>大丈夫です。
>
>お返事ありがとうございます。
>こちら(Win7 xl2010) では構文エラーになりますね。
>たくまよさんの環境は? Mac とか?

あまりPCに詳しくないですが、Win8 xls2007ですね。
どうしてなのでしょう…。ご指摘いただいたことで止まったことはないんですけど。

【74460】Re:最終行の合計をほかのセルへ転記した...
発言  UO3  - 13/6/20(木) 16:12 -

引用なし
パスワード
   ▼たくまよ さん:

こんにちは

たとえば、最後のほうの .Select の上あたりに

    .Range("D10").Value = .Range("H12").Offset(dic.Count + 1).Value
    .Range("F10").Value = Int(.Range("D10").Value * 0.8)

こんなコードをいれてはいかがですか。

【74477】Re:最終行の合計をほかのセルへ転記した...
お礼  たくまよ  - 13/6/25(火) 14:12 -

引用なし
パスワード
   ▼UO3 さん:
>▼たくまよ さん:
>
>こんにちは
>
>たとえば、最後のほうの .Select の上あたりに
>
>    .Range("D10").Value = .Range("H12").Offset(dic.Count + 1).Value
>    .Range("F10").Value = Int(.Range("D10").Value * 0.8)
>
>こんなコードをいれてはいかがですか。

ありがとうございました。
できました!!
さらなる難問が待っているので、頑張ります!

1440 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free