Excel VBA質問箱 IV

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

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


1634 / 13644 ツリー ←次へ | 前へ→

【72956】足し算と掛け算の入った転記方法 マリモ 12/10/17(水) 10:44 質問[未読]
【72957】Re:足し算と掛け算の入った転記方法 UO3 12/10/17(水) 11:18 発言[未読]
【72958】Re:足し算と掛け算の入った転記方法 マリモ 12/10/17(水) 13:02 発言[未読]
【72959】Re:足し算と掛け算の入った転記方法 ウッシ 12/10/17(水) 14:05 回答[未読]
【72974】Re:足し算と掛け算の入った転記方法 マリモ 12/10/18(木) 14:47 お礼[未読]

【72956】足し算と掛け算の入った転記方法
質問  マリモ  - 12/10/17(水) 10:44 -

引用なし
パスワード
   こんにちは。説明が苦手なので、分かりくいかもしれませんが、
宜しくお願い致します。
以下の方法で毎日受け取りしたものを振り分けしたいと考えておりますが
最初の記入段階から変更した方が効率的では?という案もありましたら、
ご指摘いただけるとありがたいです。

A1:日付 B1:コード C1:事業名 D1:通数 E1:単価
とSheet1の1行目は記入しており、2行目以降は受取記録を記入してあります。
Sheet2にコード別に通数と単価と合計金額を算出したいです。
(単価は変わる場合もあります。)

Sheet2に
A1:コード B1:事業名 C1:通数 D1:単価 E1:金額
と記入し、(2行目以降にコードと事業名はセットで違うパターンはないです。)
コード・事業名別に同じ単価の合計通数を記入し、
例えば、C2に通数が入っていれば、D2の単価をかけてE2に金額が入るように
したいです。

宜しくお願い致します。

【72957】Re:足し算と掛け算の入った転記方法
発言  UO3  - 12/10/17(水) 11:18 -

引用なし
パスワード
   ▼マリモ さん:

こんにちは。たとえば。

Sub Sample()
  Dim c As Range
  Dim v() As Variant
  Dim dkey As String
  Dim dic As Object
  Dim x As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Sheets("Sheet2")
    For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
      dkey = c.Value & vbTab & c.Offset(, 1).Value
      dic(dkey) = dic.Count + 1 '1からの連番
    Next
  End With
  
  ReDim v(1 To dic.Count, 1 To 3)
  
  With Sheets("Sheet1")
    For Each c In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
      dkey = c.Value & vbTab & c.Offset(, 1).Value
      If dic.exists(dkey) Then  'Sheet2に記載あれば
        x = dic(dkey)
        v(x, 1) = v(x, 1) + c.Offset(, 2).Value '通数足しこみ
        v(x, 2) = c.Offset(, 3).Value      '単価
        '金額計算をしたものを足しこみ
        v(x, 3) = v(x, 3) + c.Offset(, 2).Value * c.Offset(, 3).Value
      End If
    Next
  End With
  
  With Sheets("Sheet2")
    .Range("C2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
    .Select
  End With
  
  MsgBox "処理完了"
  
End Sub

【72958】Re:足し算と掛け算の入った転記方法
発言  マリモ  - 12/10/17(水) 13:02 -

引用なし
パスワード
   ▼UO3 さん:
ご提案、ありがとうございます。
説明不足で申し訳ありません。
セルの区切りは,で表記します。

Sheet1に
A列,B列,C列,D列,E列
日付,コード,事業名,通数,単価
10/5,001,バラ,3,95
10/5,001,バラ,2,110
10/5,002,ひまわり,5,95
10/5,003,コスモス,6,110
10/7,001,バラ,2,95
10/7,001,バラ,5,110
10/7,ひまわり,7,110
10/7,コスモス,2,95

と記入してあるとすると、Sheet2に
コード,事業名,通数,単価,小計
001,バラ,5,95,475
001,バラ,7,110,770
002,ひまわり,5,95,475
002,ひまわり,7,110,770
003,コスモス,2,95,190
003,コスモス,6,110,660

のような感じにまとめたいです。
日付は月毎なので、日付は省いています。
宜しくお願い致します。

【72959】Re:足し算と掛け算の入った転記方法
回答  ウッシ  - 12/10/17(水) 14:05 -

引用なし
パスワード
   こんにちは

>Sheet1に
>A列,B列,C列,D列,E列
>日付,コード,事業名,通数,単価
>10/5,001,バラ,3,95
>10/5,001,バラ,2,110
>10/5,002,ひまわり,5,95
>10/5,003,コスモス,6,110
>10/7,001,バラ,2,95
>10/7,001,バラ,5,110
>10/7,ひまわり,7,110
>10/7,コスモス,2,95

このデータを使ってマクロ自動記録を採ってせっせと修正すると、

Sub test()
  Dim sh1 As Worksheet
  Dim sh2 As Worksheet
  Dim sht As Worksheet
    
  Set sh1 = Worksheets("Sheet1")
  Set sh2 = Worksheets("Sheet2")
  Set sht = Worksheets.Add
  sh2.UsedRange.ClearContents
  Application.ScreenUpdating = False
  With sht
    sh1.Columns("B:E").Copy .Range("A1")
    .Range("A1").CurrentRegion.Sort _
      Key1:=.Range("A2"), Order1:=xlAscending, _
      Key2:=.Range("D2"), Order2:=xlAscending, _
      Header:=xlYes, OrderCustom:=1, _
      MatchCase:=False, Orientation:=xlTopToBottom, _
      SortMethod:=xlPinYin, _
      DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
    .Columns("C:C").Insert Shift:=xlToRight
    .Range("A1", .Range("A2").End(xlDown)).Offset(, 2) _
      .Formula = "=A1&"",""&B1&"",""&E1"
    .Range("F1").Value = "小計"
    .Range("A2", .Range("A2").End(xlDown)).Offset(, 5).Formula = "=D2*E2"
    .Range("A1").CurrentRegion.Subtotal _
      GroupBy:=3, Function:=xlSum, TotalList:=Array(4, 6), _
      Replace:=False, PageBreaks:=False, SummaryBelowData:=True
    .Outline.ShowLevels RowLevels:=3
    .Outline.ShowLevels RowLevels:=2
    .Columns("C:F").SpecialCells(xlCellTypeVisible).Copy sh2.Range("A1")
    Application.DisplayAlerts = False
    .Delete
  End With
  Application.DisplayAlerts = True
  With sh2
    .Columns("B:C").Insert Shift:=xlToRight
    .Columns("A:A").TextToColumns _
      Destination:=.Range("A1"), DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
      Tab:=True, Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
      FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
      TrailingMinusNumbers:=True
    .Columns("C:C").Replace _
      What:=" 集計", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
    .Columns("E:E").Delete Shift:=xlToLeft
    .Columns("D:D").Cut
    .Range("C1").Insert Shift:=xlToRight
    .UsedRange.Font.FontStyle = "標準"
    .UsedRange.Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

【72974】Re:足し算と掛け算の入った転記方法
お礼  マリモ  - 12/10/18(木) 14:47 -

引用なし
パスワード
   ▼ウッシ さん:
総計まで入れて下さり、ありがとうございました。
助かりました。

▼UO3 さん:
説明不足ですみませんでした。
ありがとうございました。

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