ここから本文です

VBAについて、下記内容がなかなか上手くいきません。 ご教示お願い致します。 ...

fuj********さん

2019/10/2000:13:06

VBAについて、下記内容がなかなか上手くいきません。
ご教示お願い致します。

①sheet1にデータを蓄積します。

(新しいデータは最終行に追加されます)
②sheet2の赤枠内のセルE20に西暦、セルG20に月を入力。
③集計ボタンを押し、sheet2 セルE20とセルG20をもとに
・sheet2のセルA2にセル20に入力した西暦を表示 例:2019
・西暦と月をもとにsheet1のデータをsheet2の表に転記
この時、入力した月までのデータを品名別で月毎に転記したい。(年度は4月1日で次年度)
例:2019年6月と入力した場合
sheet1の9行目~11行目をsheet2に転記

Sheet2,Sheet1,セルE20,セルG20,ws2.Range,西暦,E20&quot

閲覧数:
107
回答数:
2
お礼:
100枚

違反報告

ベストアンサーに選ばれた回答

プロフィール画像

カテゴリマスター

kky********さん

2019/10/2008:38:08

一例です。

Sub Sample()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim smon As Integer
Dim sdate As Date, edate As Date
Dim r1 As Long, r2 As Integer
Dim c As Integer
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
With sh2
If .Range("E20") = "" Then
MsgBox "年が入力されていません"
Exit Sub
End If
If .Range("G20") = "" Then
MsgBox "月が入力されていません"
Exit Sub
End If
Application.ScreenUpdating = False
.Range("A2").Value = .Range("E20").Value
smon = .Range("G20")
edate = DateAdd("m", 1, DateSerial(.Range("E20"), smon, 1)) - 1
If smon > 4 Then
sdate = DateSerial(.Range("E20"), 4, 1)
Else
sdate = DateSerial(.Range("E20") - 1, 4, 1)
End If
End With
With sh1
For r1 = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Range("A" & r1) >= sdate And .Range("A" & r1) <= edate Then
If Month(.Range("A" & r1)) > 3 Then
r2 = Month(.Range("A" & r1)) + 2
Else
r2 = Month(.Range("A" & r1)) + 14
End If
If .Range("B" & r1) = "りんご" Then
c = 2
Else
c = 6
End If
sh2.Cells(r2, c).Value = .Range("B" & r1).Value
sh2.Cells(r2, c + 1).Value = .Range("C" & r1).Value
End If
Next r1
End With
Application.ScreenUpdating = True
End Sub

  • 質問者

    fuj********さん

    2019/10/2201:46:42

    ご回答ありがとうございます!
    内容、理解できました。
    年度の判定に苦慮しておりましたが助かりました。
    あと、行番号と月の値で計算しデータを飛ばすんですね。
    全然考えもしてませんでした。勉強不足です。。。

    ちなみに下記のRangeはB→CとC→Dですよね?

    sh2.Cells(r2, c).Value = .Range("B" & r1).Value
    sh2.Cells(r2, c + 1).Value = .Range("C" & r1).Value

  • その他の返信(1件)を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

ベストアンサー以外の回答

1〜1件/1件中

auq********さん

編集あり2019/10/2100:40:24

計算式で出来そうでしたので、集計を計算式で行ってから値で貼り付けを行っています。
E21セルは計算式に使用するので空けておいて下さい。

Option Explicit
Sub test()

Dim ws2 As Worksheet
Set ws2 = Sheets("Sheet2")

ws2.Range("A2").Formula = "=$E$20"

With Union(ws2.Range("A6").Resize(12), ws2.Range("E6").Resize(12))
.NumberFormatLocal = "m月"
.Formula = "=DATE($E$20,ROW(4:4),1)"
End With

ws2.Range("E21").Formula = "=IF($G$20<=3,$E$20+1,"""")"

ws2.Range("B6:C17").Formula = "=IF($A6>DATE(MAX($E$20:$E$21),$G$20,1),"""",SUMIFS(Sheet1!C:C,Sheet1!$A:$A,"">=""&$A6,Sheet1!$A:$A,""<=""&EOMONTH($A6,0),Sheet1!$B:$B,""りんご""))"
ws2.Range("F6:G17").Formula = "=IF($A6>DATE(MAX($E$20:$E$21),$G$20,1),"""",SUMIFS(Sheet1!C:C,Sheet1!$A:$A,"">=""&$A6,Sheet1!$A:$A,""<=""&EOMONTH($A6,0),Sheet1!$B:$B,""みかん""))"

ws2.UsedRange.Value = ws2.UsedRange.Value

ws2.Range("E21").ClearContents

End Sub


※上記コードの
ws2.UsedRange.Value = ws2.UsedRange.Value

ws2.Range("E21").ClearContents
をコメントアウトしてから実行すると計算式が残りますので参考まで。

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

あわせて知りたい

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる