[[20181016123741]] 『条件指定 行挿入』(ななし) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『条件指定 行挿入』(ななし)

データ入力があった日を
2018/10/1 ○○○
2018/10/2 △△△
2018/10/4 ○○○
2018/10/4 △△△
というように記録している"元データ"というシートから
別シートに○○○の記録された行、△△△の記録された行を持っていきます

現在は
A1に○○○や△△△(欲しいデータ)を入力し、データを入れたい行に
=IF(ROW(D6)>COUNTIF(元データ!$B$2:$B$500,$A$1),"",INDEX(元データ!D$1:D$500,SMALL(INDEX((元データ!$B$2:$B$500<>$A$1)*10^5+ROW(元データ!$B$2:$B$500),),ROW(D6))))
という関数を適応しています

この方法では○○○を例にとると
2018/10/1 ○○○
2018/10/4 ○○○
というように記録されていきます

これを
2018/10/1 ○○○
2018/10/2
2018/10/3
2018/10/4 ○○○
というように、データが無い日は日付を挿入するようにしたいです

どのようにしたら良いでしょうか?
マクロでも関数でも大丈夫です

< 使用 Excel:Excel2013、使用 OS:Windows10 >


 日付をハンド入力。

 =IF(COUNTIFS(元日付範囲,日付セル,元データ範囲,"〇〇〇"),"〇〇〇","")

 で、いいよーな。
 
(GobGob) 2018/10/16(火) 13:08

Sub main()
    Dim c As Range, r As Range, rr As Range, i As Long, sht As Worksheet
    For Each c In Sheets("元データ").Range("B:B").SpecialCells(2)
        If Not Evaluate("isref('" & c.Value & "'!A1)") Then
            Sheets.Add
            Set sht = ActiveSheet
            sht.Name = c.Value
            Sheets("元データ").Cells.Copy
            sht.Cells.PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
            Set r = sht.Range("A1")
            For i = WorksheetFunction.Min(Sheets("元データ").Range("A:A")) To WorksheetFunction.Max(Sheets("元データ").Range("A:A"))
                r.Value = i
                Set rr = Sheets("元データ").Range("B:B").Find(c.Value, , , xlWhole)
                If Not rr Is Nothing Then
                    If rr.Offset(, -1).Value = i Then r.Offset(, 1).Value = c.Value
                        Set f = rr
                        Do
                            Set rr = Sheets("元データ").Range("B:B").FindNext(rr)
                            If rr.Address = f.Address Then
                                Exit Do
                            Else
                                If rr.Offset(, -1).Value = i Then r.Offset(, 1).Value = c.Value
                            End If
                        Loop
                End If
                Set r = r.Offset(1)
            Next i
        End If
    Next c
End Sub
(mm) 2018/10/16(火) 14:05

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.