特定の列に値があれば日付を取得したい。(空欄なら無視)

Question

左の様な元データから右の様に日付を抽出したいです。

＊以下、元データの説明
・データは月によって量が違います。
・データはさらに別の元データ(1月～12月まである)から月ごとにシートに分けて抽出済みです。
・データの値は必ず"1"が入ります。
・データ1，2，3いずれにもデータが無ければ日付はありません。
・同じ日に同じデータに値が入る事もあります。(元データの3行目と4行目のデータ3)
・同じ日に複数のデータに値が入る事もあります。(元データ3行目のデータ2とデータ3)

＊以下、やりたい事
・抽出シートに1，2，3それぞれに値がある日の日付を抽出したい。
・データに値が無しの行は無視(抽出せずに詰める)する。
・同じ日に同じデータがある時はその数分日付を抽出。(抽出データのデータ3の2行目、3行目)

　要するに特定の列に値があればC列の値を抽出したいが、値の無い行は無視をする(抽出データには空欄を入れるのではなく上に詰める)です。

以上分かりづらい質問ですがお力添えお願いいたします。

d-q-t-p · Accepted Answer

#1です。

数式案をお勧めするつもりはないので別にいいのですが

> 教えて頂いた物はシートが表示された状態でCtrl+Shift+Enterという作業
> をしないといけない物ですよね？
違います。数式を確定する時の操作であって 利用者には無関係な話です。
どうしても嫌なら 名前定義してやれば済みます。

マクロでやるにしても

Sub Macro1()
  Dim sht1 As Worksheet, sht2 As Worksheet
  Dim sht1Val As Variant, lr As Long
  Dim i As Long, j As Long
  Set sht1 = ThisWorkbook.Worksheets("Sheet1")
  Set sht2 = ThisWorkbook.Worksheets("Sheet2")
  Application.ScreenUpdating = False
  With sht1
    sht1Val = .Range("B2:F" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
  End With
  With sht2
    .Range("A:D").ClearContents
    .Range("A1").Value = sht1.Range("B1").Value
    .Range("B1:D1").Value = sht1.Range("D1:F1").Value
    For i = 1 To UBound(sht1Val)
      For j = 3 To 5
        If sht1Val(i, j) = 1 Then
          lr = .Cells(Rows.Count, j - 1).End(xlUp).Row
          .Cells(lr + 1, 1).Value = sht1Val(i, 1)
          .Cells(lr + 1, j - 1).Value = sht1Val(i, 2)
        End If
      Next j
    Next i
  End With
  Application.ScreenUpdating = False
  Set sht1 = Nothing: Set sht2 = Nothing
End Sub

tom04 · Answer

No.2です。

投稿後気づいたのですが・・・
＞・データはさらに別の元データ(1月～12月まである)から月ごとにシートに分けて抽出済みです。

すなわち、Sheet1には1か月分のデータだけしかないのですね？
そうであればかなり簡単にできます。

前回のコードはすべて消去し↓のコードにしてみてください。

Sub Sample2()
    Dim i As Long, j As Long, lastRow As Long
    Dim myMax As Long, wS As Worksheet
        Set wS = Worksheets("Sheet2")
            lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
                If lastRow > 1 Then
                    Range(wS.Cells(2, "A"), wS.Cells(lastRow, "D")).ClearContents
                End If
            With Worksheets("Sheet1")
                For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
                For j = 4 To 6
                    If .Cells(i, j) <> "" Then
                        wS.Cells(i, "A") = .Cells(i, "B")
                        wS.Cells(i, j - 2) = .Cells(i, "C")
                    End If
                Next j
                Next i
                lastRow = wS.UsedRange.Rows.Count
                    On Error Resume Next
                    Range(wS.Cells(2, "A"), wS.Cells(lastRow, "D")).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
                For j = 2 To 4
                    myMax = WorksheetFunction.Max(myMax, wS.Cells(Rows.Count, j).End(xlUp).Row)
                Next j
                    lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
                        If lastRow > myMax Then
                            Range(wS.Cells(myMax + 1, "A"), wS.Cells(lastRow, "A")).ClearContents
                        End If
            End With
            MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

tom04 · Answer

こんにちは！

VBAでの一例です。
Sheet2の表示は月だけになっているので、Sheet1は1年分のデータという前提です。

尚、Sheet3を作業用のシートとして使っていますので、Sheet3は全く使用していない状態にしておいてください。
標準モジュールです。

Sub Sample1()
Dim i As Long, j As Long, k As Long, lastRow As Long
Dim myMax As Long, wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
lastRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(wS2.Cells(2, "A"), wS2.Cells(lastRow, "F")).ClearContents
End If
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("G:G").Insert
.Range("G1") = "ダミー"
Range(.Cells(2, "G"), .Cells(lastRow, "G")).Formula = "=IF(COUNT(D2:F2),B2,"""")"
.Range("G:G").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
wS3.Range("C:G").ClearContents
If wS3.Cells(i, "A") <> "" Then
.Range("A1").AutoFilter field:=7, Criteria1:=wS3.Cells(i, "A")
.Range("B:F").SpecialCells(xlCellTypeVisible).Copy wS3.Range("C1")
For k = 2 To wS3.Cells(Rows.Count, "C").End(xlUp).Row
For j = 5 To 7
If wS3.Cells(k, j) <> "" Then
wS3.Cells(k, j) = wS3.Cells(k, "D")
End If
Next j
Next k
lastRow = wS3.Cells(Rows.Count, "C").End(xlUp).Row
On Error Resume Next '//←念のため//
Range(wS3.Cells(2, "E"), wS3.Cells(lastRow, "G")).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
For j = 5 To 7
myMax = WorksheetFunction.Max(myMax, wS3.Cells(Rows.Count, j).End(xlUp).Row)
Next j
lastRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range(wS3.Cells(2, "C"), wS3.Cells(myMax, "C")).Copy
wS2.Cells(lastRow, "A").PasteSpecial Paste:=xlPasteValues
Range(wS3.Cells(2, "E"), wS3.Cells(myMax, "G")).Copy
wS2.Cells(lastRow, "B").PasteSpecial Paste:=xlPasteValues
End If
Next i
.AutoFilterMode = False
.Range("G:G").Delete
wS3.Cells.Clear
End With
Application.ScreenUpdating = True
wS2.Activate
wS2.Range("A1").Select
MsgBox "完了"
End Sub

※　もっと簡単な方法があるかもしれませんが、
まずはこの程度で・・・m(_ _)m

d-q-t-p · Answer

Excelに抽出の「関数」はありません。

既にマクロを使っているなら 数式で処理するのは論外だと思いますけど。

=IFERROR(1/IFERROR(1/MOD(SMALL((Sheet1!D$2:D$12="")*10^10+Sheet1!$C$2:$C$12,ROW($B1)),10^10),0),"")
 Ctrl + Shift + Enterで確定

> VBAは勉強し始めたばかりで
やるなら基礎から勉強なさるべきかと思います。

特定の列に値があれば日付を取得したい。(空欄なら無視)

#1です。

No.2です。

こんにちは！

Excelに抽出の「関数」はありません。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング