Excel マクロについて質問です。 sheet1に以下の表の内容が入力してあります。

Excel マクロについて質問です。 sheet1に以下の表の内容が入力してあります。 ㅤㅤ↓ ㅤㅤ AㅤㅤㅤㅤBㅤㅤㅤㅤCㅤㅤㅤㅤDㅤㅤㅤㅤEㅤㅤㅤㅤㅤㅤAF 1ㅤㅤㅤㅤㅤㅤ10/1ㅤㅤ10/2ㅤㅤ10/3ㅤㅤ10/4ㅤ〜ㅤ10/31 2ㅤAさんㅤㅤㅤ○ㅤㅤㅤㅤ○ 3ㅤBさんㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤ○ 4ㅤCさんㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤ○ㅤㅤㅤㅤㅤ○ 5ㅤDさんㅤㅤㅤ○ㅤㅤㅤㅤ 上段のアルファベットが行番号、左の数字が列番号とします。 このsheet1からマクロを使って、指定した期間(例:10/2〜10/4)して、sheet2に以下のように表示したいです。 ㅤㅤ↓ ㅤㅤ AㅤㅤㅤㅤBㅤㅤㅤㅤCㅤㅤㅤㅤDㅤㅤㅤㅤEㅤㅤㅤㅤFㅤㅤㅤㅤG 1ㅤㅤㅤㅤㅤㅤ10/2ㅤㅤ10/3ㅤㅤ10/4ㅤㅤ 2ㅤAさんㅤㅤㅤ○ㅤㅤㅤㅤ 3ㅤBさんㅤㅤㅤㅤㅤㅤㅤㅤ○ 4ㅤCさんㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤ○ 5ㅤ 指定した期間を抽出しそれ以外の期間については削除。 そして期間内に一つでも○があれば列の中に表示し、一つも○が無ければその人も削除。 VBAに詳しい方いらっしゃいましたら、ご教授願えませんでしょうか? 質問に言葉足らずなところがあるかもしれませんが、よろしくお願いいたします。 ♯Excel ♯VBA ♯チャールズシモニー

補足

sheet1の表の訂正をさせてください。 ㅤㅤㅤBㅤㅤㅤCㅤㅤㅤㅤEㅤㅤㅤㅤㅤFㅤㅤㅤㅤGㅤㅤㅤㅤHㅤㅤㅤㅤ...... 4ㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤ9/26ㅤㅤ9/27ㅤㅤ9/28ㅤㅤ9/29ㅤ〜ㅤ10/31 6ㅤ1班 Aさんㅤㅤㅤ○ㅤㅤㅤㅤ○ 8ㅤ2班 Bさんㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤ○ 10ㅤ3班 Cさんㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤㅤ○ㅤㅤㅤㅤㅤ○ 12ㅤ4班 Dさんㅤㅤㅤ○ㅤㅤㅤㅤ A列、D列については非表示にしてあります。左数字4行目に日付が40日分表示してあり、J4のセルに必ずその月の1日が記入してあり、それぞれ一つセルが横に移動するたびに±1してある状況です。なので上記の場合だとJ4のセルに10/1なのでE4には9/26といった具合です。当初の質問に記載している指定した期間については、この40日分から指定した7日間を抽出したいと考えております。 たくさんの回答ありがとうございます。マクロをコピーさせていただいて、実行できたのですが、表を具体的に書けてなかった私のせいで、うまくいきませんでした。申し訳ないですが、よろしくお願いいたします。

Windows系 | Excel54閲覧xmlns="http://www.w3.org/2000/svg">100

ベストアンサー

0

アップし直します。 投稿されたコードを修正出来ないなら、正確に実態を反映した質問にしましょう。 開始日から7日との限定だったので、開始日だけの入力にしたのと、日付のエラー処理を修正しました。 Dim WS1 As Worksheet, LastRow1, R1, C1, LastCol1 Dim WS2 As Worksheet, C2, R2 Dim Day1, Day2, FLG As Boolean Set WS1 = Worksheets("Sheet1") Set WS2 = Worksheets("Sheet2") Day1 = InputBox("開始日を入力して下さい。" & vbCr & _ "(日付の表示形式はシート1と同一で)") If Day1 = "" Then Exit Sub If CDate(Day1) < CDate(WS1.Cells(4, "E").Text) Then     MsgBox "日付が表の範囲外です。"     Exit Sub End If Day2 = Format(DateAdd("d", 6, Day1), "m/d") If DateAdd("d", 39, WS1.Cells(4, "E").Text) < CDate(Day2) Then     MsgBox "入力日の1週間後は表の範囲外です・"     Exit Sub End If WS2.UsedRange.ClearContents LastRow1 = WS1.Cells(Rows.Count, "C").End(xlUp).Row LastCol1 = WS1.Cells(4, Columns.Count).End(xlToLeft).Column FLG = False C2 = 2 R2 = 2 For C1 = 2 To LastCol1     If WS1.Cells(4, C1).Text = Day1 Then FLG = True     '     If FLG = True Then         WS2.Cells(1, C2) = WS1.Cells(4, C1)         For R1 = 6 To LastRow1             If WS1.Cells(R1, C1) = "〇" Then                 WS2.Cells(R2, 1) = WS1.Cells(R1, "C")                 WS2.Cells(R2, C2) = "〇"                 R2 = R2 + 1             End If         Next R1         C2 = C2 + 1     End If     '     If WS1.Cells(4, C1).Text = Day2 Then Exit For Next C1

ThanksImg質問者からのお礼コメント

ありがとうございました!!

お礼日時:9/19 19:59

その他の回答(2件)

0

再々回答です。InputBoxに「10/1」or「10-1」or「2020/10/1」のように入力すると1週間分のデータがシート2に抽出されます。 Sub test_6_5() Dim sh1, sh2 As Worksheet Dim a, b As Date Dim c, i, j, n, m, r, aa, ii, num As Long Dim myInp As Date Dim iiary As Variant Dim FC As Range Dim ary Application.ScreenUpdating = False Set sh1 = Worksheets("Sheet1") Set sh2 = Worksheets("Sheet2") sh1.Select myInp = InputBox(prompt:="開始日「10/1 or 10-1 or 2020/10/1」のように入力してください。") If myInp < DateAdd("yyyy", -4, Date) Then MsgBox "入力が間違っています。" Exit Sub End If a = myInp b = myInp + 6 iiary = Array(0, 0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17) Set FC = Range("A4").EntireRow.Find(What:=Format(CDate(a), "m/d"), LookIn:=xlValues) aa = FC.Column r = Cells(Rows.Count, 1).End(xlUp).Row c = Cells(4, Columns.Count).End(xlToLeft).Column ary = WorksheetFunction.Transpose(Range(Cells(4, 1), Cells(14, c))) With sh2 .Range("A1:Z100").ClearContents For i = aa To aa + 6 If i > c Then Exit For .Cells(1, i - (aa - 2)) = Format(CDate(ary(i, 1)), "m/d") Next i End With n = 1 m = 0 For i = 1 To UBound(ary, 2) For j = 1 To UBound(ary, 1) If ary(j, i) = "○" And j > aa - 1 And j < aa + 6 + 1 Then If n = 1 Then ii = iiary(i) num = i - ii End If If i > c Then Exit Sub If ary(1, i - 1) <> "" Then If sh2.Cells(i - ii - m, 1) = "" And i - ii - m <= 2 Then m = 0 ElseIf ary(2, i) <> sh2.Cells(i - ii - m, 1) Then n = n + 1 If i - ii - m <> num + n - 1 Then m = i - ii - (num + n - 1) End If Else If i - ii - m <> num + n - 1 Then m = i - ii - (num + n - 1) End If End If End If With sh2 .Cells(i - ii - m, 1) = ary(2, i) '氏名 .Cells(i - ii - m, j - (aa - 2)) = ary(j, i) '○ End With End If Next j Next i Application.ScreenUpdating = True End Sub

0

補足より、日付は7日間という事なので、開始日だけ入力するようにしました。 Sub test() Dim idate As String Dim sdate As Date Dim sh As Worksheet Dim rmax As Long Dim r As Long, r2 As Long Dim c As Integer Dim sc As Integer, ec As Integer Dim rng As Range Dim ck As Variant '日付入力 Do idate = InputBox("開始日を yyyy/m/d の形式で入力して下さい") If StrPtr(idate) = 0 Then Exit Sub ' キャンセル時に終了 If IsDate(idate) Then Exit Do Loop sdate = DateValue(idate) With Worksheets("Sheet1") If sdate < .Cells(4, 5) Or sdate + 6 > .Cells(4, 44) Then MsgBox "指定の日付がSheet1にありません" Exit Sub End If End With '処理 Application.ScreenUpdating = False '指定日付をSheet2にセット Set sh = Worksheets("Sheet2") With sh .Cells.Clear For c = 3 To 9 .Cells(1, c) = sdate + c - 3 .Range(.Cells(1, 3), .Cells(1, 9)).NumberFormatLocal = "m/d" .Range(.Cells(1, 3), .Cells(1, 9)).HorizontalAlignment = xlCenter Next c End With With Worksheets("Sheet1") rmax = .Cells(Rows.Count, 3).End(xlUp).Row Set rng = .Range(.Cells(4, 5), .Cells(4, 44)) sc = Application.Match(CLng(sdate), rng, 0) + 4 ec = sc + 6 '有効名前をSheet2にセット r2 = 1 For r = 6 To rmax If WorksheetFunction.CountA(.Range(.Cells(r, sc), .Cells(r, ec))) > 0 Then r2 = r2 + 1 sh.Cells(r2, 1) = .Cells(r, 2) sh.Cells(r2, 2) = .Cells(r, 3) End If Next r End With 'Sheet2に入れた名前 With sh Set rng = .Range("B2:B" & .Cells(Rows.Count, 2).End(xlUp).Row) 'tbl = .Range(.Cells(1, 2), .Cells(1, .Cells(1, Columns.Count).End(xlToLeft).Column)) End With '○をセット With Worksheets("Sheet1") For r = 6 To rmax ck = Application.Match(.Cells(r, 3), rng, 0) If IsError(ck) = False Then For c = 3 To 9 If .Cells(r, sc + c - 3) = "○" Then sh.Cells(ck + 1, c) = "○" sh.Cells(ck + 1, c).HorizontalAlignment = xlCenter End If Next c End If Next r End With Application.ScreenUpdating = True End Sub

すみません、コード中央あたりに 'tbl = .Range(.Cells(1, 2), .Cells(1, .Cells(1, Columns.Count).End(xlToLeft).Column)) がありますが、消し忘れです。 この1行は削除して下さい。