[[20190124103916]]　『VBA 最大値を取得し、条件を指定して貼り付けたい』（w01f_2614）　ページの最後に飛ぶ

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

　

『VBA 最大値を取得し、条件を指定して貼り付けたい』（w01f_2614）

初歩的かもしれない質問でお恥ずかしいのですが、知恵をお貸しいただきたいです。

1年の中で最大の数値が含まれる日付の値全てを別シートに貼り付けるというVBAプログラムを作成したいです。
また、この場合の1日とは前後1日分ではなく、その時間が含まれる1日の事です。

例えば、30分毎の売り上げ金額が入力されたexcelシートが1年分あるとします。

1年間の中で最大の売り上げ金額が、2018/2/14 12:30に存在すると仮定します。

その場合に、2018/2/14 0:00〜 2018/2/14 23:30
の値を抜き出し、別シートに貼り付けるというプログラムを作成したいです。

データの形は、

2018/2/14 0:00 300
2018/2/14 0:30 200
・
・
・
2018/2/14 23:30 500

のようになっています

自分でも一通り調べてみたのですが、どうしてもしっくり来るものが見つかりませんでした。

どうぞよろしくお願い致します。

＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞

---

 例題が少なすぎます。

[[20110209184943]]　『[談]シートレイアウトの投稿どうしてますか？』（ｍｏｍｏ）

 ↑のリンクにあるコードで、
 １）最低でも2日分のデータ
 ２）出力結果
 ３）最大が複数日あった場合
 を提示できますか？

 今の状態だと、日付と時間が同じセルなのか、別のセルなのか、
 数量もどの列にあるのかわかりません。

（稲葉） 2019/01/24(木) 12:29

---

 おはようございます。

 暇だったんで想像力をMaxにしてちょっと書いてみました。

 Sheet1のA列に日付、B列に数値が入力されているとして、Sheet2に結果を書き出します。

 でも、書いてたら、、そのまんまだね(^^;　まぁ、、、参考になれば幸いです。

 もう、、見てないかな？？？？

 Sheet1
 2018/2/14 0:00	8378
 2018/2/14 0:30	1397
 2018/2/14 1:00	1690
 2018/2/14 1:30	5451
 2018/2/14 2:00	8891
 2018/2/14 2:30	1298
 2018/2/14 3:00	351
 以下続きます。

 Sheet2
 2018/2/16 0:00	3634
 2018/2/16 0:30	6957
 2018/2/16 1:00	1529
 2018/2/16 1:30	319
 2018/2/16 2:00	439
 2018/2/16 2:30	754
 2018/2/16 3:00	702
 2018/2/16 3:30	4480
 以下続きます。

 Option Explicit
Sub てすと()
Dim MyA As Variant
Dim MyAry() As Variant
Dim 最大値 As Double
Dim 検索日 As Date
Dim i As Long
Dim ii As Long
Dim k As Long
With Sheets("Sheet1")
    MyA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
End With
With Application
    最大値 = .Max(.Index(MyA, 0, 2))
End With
ii = 1
For i = LBound(MyA, 1) To UBound(MyA, 1)
    If MyA(i, 2) = 最大値 Then
        検索日 = Format(MyA(i, 1), "yyyy/m/d")
        探索 MyA, MyAry, i, ii, 検索日, k
    End If
    If Format(MyA(i, 1), "yyyy/m/d") = 検索日 Then
        k = k + 1
        ReDim Preserve MyAry(1 To 2, 1 To k)
        MyAry(1, k) = MyA(i, 1)
        MyAry(2, k) = MyA(i, 2)
        MyA(i, 2) = ""
    End If
Next
With Sheets("Sheet2")
    .Cells.Clear
    .Range("A1").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
End With
Erase MyA, MyAry
End Sub
Sub 探索(ByRef x As Variant, _
            ByRef y As Variant, _
            ByRef i As Long, _
            ByRef ii As Long, _
            ByVal 検索日 As Date, _
            ByRef k As Long)
    For ii = ii To UBound(x, 1)
        If ii = i Then Exit Sub
        If x(ii, 2) <> "" Then
            If Format(x(ii, 1), "yyyy/m/d") = 検索日 Then
                k = k + 1
                ReDim Preserve y(1 To 2, 1 To k)
                y(1, k) = x(ii, 1)
                y(2, k) = x(ii, 2)
                x(ii, 2) = ""
            End If
        End If
    Next
End Sub

 >1年の中で最大の数値が含まれる日付の値全てを別シートに貼り付けるというVBAプログラムを作成したいです。 

 よくよく考えたら最大値が同じ日付の中で複数ある場合もあるでしょうし、、、
ちょっと見直しました。2018/1/26 20:40
（SoulMan） 2019/01/26(土) 10:54

---

 普通にディクショナーを使えばいいんでしょうけど、、、

 Option Explicit
Sub てすと()
Dim MyDic As Object
Dim MyA As Variant
Dim MyAry() As Variant
Dim 最大値 As Double
Dim i As Long
Dim k As Long
Set MyDic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
    MyA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
End With
With Application
    最大値 = .Max(.Index(MyA, 0, 2))
End With
For i = LBound(MyA, 1) To UBound(MyA, 1)
    If MyA(i, 2) = 最大値 Then
        MyDic(Format(MyA(i, 1), "yyyy/m/d")) = Empty
    End If
Next
For i = LBound(MyA, 1) To UBound(MyA, 1)
    If MyDic.Exists(Format(MyA(i, 1), "yyyy/m/d")) Then
        k = k + 1
        ReDim Preserve MyAry(1 To 2, 1 To k)
        MyAry(1, k) = MyA(i, 1)
        MyAry(2, k) = MyA(i, 2)
    End If
Next
With Sheets("Sheet2")
    .Cells.Clear
    .Range("A1").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
End With
Set MyDic = Nothing
Erase MyA, MyAry
End Sub
（SoulMan） 2019/01/26(土) 21:55

---

 書き方もいろいろあるなぁ、、、、と、私も暇人ですねぇ(笑)

 Option Explicit
Sub てすと()
Dim MyA As Variant
Dim MyAry() As Variant
Dim x() As Variant
Dim z As Variant
Dim 最大値 As Double
Dim i As Long
Dim k As Long
Dim n As Long
With Sheets("Sheet1")
    MyA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
End With
With Application
    最大値 = .Max(.Index(MyA, 0, 2))
End With
ReDim x(0)
For i = LBound(MyA, 1) To UBound(MyA, 1)
    If MyA(i, 2) = 最大値 Then
        z = Application.Match(Format(MyA(i, 1), "yyyy/m/d"), x, 0)
        If IsError(z) Then
            ReDim Preserve x(n)
            x(n) = Format(MyA(i, 1), "yyyy/m/d")
            n = n + 1
        End If
    End If
Next
For i = LBound(MyA, 1) To UBound(MyA, 1)
    z = Application.Match(Format(MyA(i, 1), "yyyy/m/d"), x, 0)
    If Not IsError(z) Then
        k = k + 1
        ReDim Preserve MyAry(1 To 2, 1 To k)
        MyAry(1, k) = MyA(i, 1)
        MyAry(2, k) = MyA(i, 2)
    End If
Next
With Sheets("Sheet2")
    .Cells.Clear
    .Range("A1").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
End With
Erase MyA, MyAry, x
End Sub
もう寝ましょzzzzzzzzzzzz
（SoulMan） 2019/01/26(土) 22:50

---

 おはようございます。
お騒がせしています。すみません。

 ついでなので他にないかなと、、、ほとんどおんなじ様なもんですけど、
SortedList　と
ArrayList　と
Collection　版
を書いてみました。

 トピ主さん不在なんですど、ディクショナリーって便利なんですねぇぇぇ
他にもないか探してみます。(暇人か(笑)）

 Option Explicit
Sub てすと()
Dim MyScs As Object
Dim MyA As Variant
Dim MyAry() As Variant
Dim 検索日 As String
Dim 最大値 As Double
Dim i As Long
Dim k As Long
Set MyScs = CreateObject("System.Collections.SortedList")
With Sheets("Sheet1")
    MyA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
End With
With Application
    最大値 = .Max(.Index(MyA, 0, 2))
End With
For i = LBound(MyA, 1) To UBound(MyA, 1)
    If MyA(i, 2) = 最大値 Then
        検索日 = Format(MyA(i, 1), "yyyy/m/d")
        MyScs(検索日) = Empty
    End If
Next
For i = LBound(MyA, 1) To UBound(MyA, 1)
    検索日 = Format(MyA(i, 1), "yyyy/m/d")
    If MyScs.Contains(検索日) Then
        k = k + 1
        ReDim Preserve MyAry(1 To 2, 1 To k)
        MyAry(1, k) = MyA(i, 1)
        MyAry(2, k) = MyA(i, 2)
    End If
Next
With Sheets("Sheet2")
    .Cells.Clear
    .Range("A1").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
End With
Set MyScs = Nothing
Erase MyA, MyAry
End Sub

 Option Explicit
Sub てすと()
Dim MyScA As Object
Dim MyA As Variant
Dim MyAry() As Variant
Dim 検索日 As String
Dim 最大値 As Double
Dim i As Long
Dim k As Long
Set MyScA = CreateObject("System.Collections.ArrayList")
With Sheets("Sheet1")
    MyA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
End With
With Application
    最大値 = .Max(.Index(MyA, 0, 2))
End With
For i = LBound(MyA, 1) To UBound(MyA, 1)
    If MyA(i, 2) = 最大値 Then
        検索日 = Format(MyA(i, 1), "yyyy/m/d")
        MyScA.Add 検索日
    End If
Next
For i = LBound(MyA, 1) To UBound(MyA, 1)
    検索日 = Format(MyA(i, 1), "yyyy/m/d")
    If MyScA.Contains(検索日) Then
        k = k + 1
        ReDim Preserve MyAry(1 To 2, 1 To k)
        MyAry(1, k) = MyA(i, 1)
        MyAry(2, k) = MyA(i, 2)
    End If
Next
With Sheets("Sheet2")
    .Cells.Clear
    .Range("A1").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
End With
Set MyScA = Nothing
Erase MyA, MyAry
End Sub

 Option Explicit
Sub てすと()
Dim MyCol As Collection
Dim MyA As Variant
Dim MyAry() As Variant
Dim x As Variant
Dim y() As Variant
Dim z As Variant
Dim 最大値 As Double
Dim i As Long
Dim k As Long
Dim n As Variant
Set MyCol = New Collection
With Sheets("Sheet1")
    MyA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
End With
With Application
    最大値 = .Max(.Index(MyA, 0, 2))
End With
For i = LBound(MyA, 1) To UBound(MyA, 1)
    If MyA(i, 2) = 最大値 Then
        MyCol.Add Format(MyA(i, 1), "yyyy/m/d")
    End If
Next
ReDim y(n)
For Each x In MyCol
    ReDim Preserve y(n)
    y(n) = x
    n = n + 1
Next
For i = LBound(MyA, 1) To UBound(MyA, 1)
    z = Application.Match(Format(MyA(i, 1), "yyyy/m/d"), y, 0)
    If Not IsError(z) Then
        k = k + 1
        ReDim Preserve MyAry(1 To 2, 1 To k)
        MyAry(1, k) = MyA(i, 1)
        MyAry(2, k) = MyA(i, 2)
    End If
Next
With Sheets("Sheet2")
    .Cells.Clear
    .Range("A1").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
End With
Set MyCol = Nothing
Erase MyA, MyAry, y
End Sub
（SoulMan） 2019/01/27(日) 08:51

---

 やっぱり検索の王道はFindかなと、、、、
 そろそろネタが尽きてきた様な？？？？(^^;

 Option Explicit
Sub てすと()
Dim MyA As Variant
Dim MyAry() As Variant
Dim y() As Variant
Dim z As Variant
Dim Mytbl As Range
Dim x As Range
Dim r As Range
Dim 検索日 As Range
Dim 最大値 As Double
Dim 最初 As String
Dim i As Long
Dim k As Long
Dim n As Variant
With Sheets("Sheet1")
    With .Range("A1", .Range("A" & Rows.Count).End(xlUp))
        MyA = .Resize(, 2).Value
        Set Mytbl = .Offset(, 1)
    End With
End With
With Application
    最大値 = .Max(.Index(MyA, 0, 2))
End With
Set r = Mytbl.Find(最大値, , , , , xlNext, True)
If Not r Is Nothing Then
    最初 = r.Address
    Do
        If 検索日 Is Nothing Then
            Set 検索日 = r.Offset(, -1)
        Else
            Set 検索日 = Union(検索日, r.Offset(, -1))
        End If
        Set r = Mytbl.FindNext(r)
    Loop Until r.Address = 最初
End If
ReDim y(n)
For Each x In 検索日
    ReDim Preserve y(n)
    y(n) = Format(x, "yyyy/m/d")
    n = n + 1
Next
For i = LBound(MyA, 1) To UBound(MyA, 1)
    z = Application.Match(Format(MyA(i, 1), "yyyy/m/d"), y, 0)
    If Not IsError(z) Then
        k = k + 1
        ReDim Preserve MyAry(1 To 2, 1 To k)
        MyAry(1, k) = MyA(i, 1)
        MyAry(2, k) = MyA(i, 2)
    End If
Next
With Sheets("Sheet2")
    .Cells.Clear
    .Range("A1").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
End With
Set Mytbl = Nothing
Erase MyA, MyAry, y
End Sub
※お馬ちゃん、考えよっと(笑)
（SoulMan） 2019/01/27(日) 11:01

---

 もう一つ大きなSheetというメモリーがありました。

 ここに書き込んでおけば消えませんね。ただ、オートフィルターを使ったので見出しが必要になります。

 >自分でも一通り調べてみたのですが、どうしてもしっくり来るものが見つかりませんでした。 

 どれか一つでもしっくり来るのがあるといいのにね(^^;

 Option Explicit
Sub てすと()
Dim MyA As Variant
Dim MyB As Variant
Dim MyAry() As Variant
Dim z As Variant
Dim MytblA As Range
Dim MytblB As Range
Dim 検索日 As Date
Dim ws As Worksheet
Dim 最大値 As Double
Dim i As Long
Dim k As Long
Dim MyFlg As Boolean
For Each ws In Worksheets
    If ws.Name = "抽出先" Then MyFlg = True
Next
If MyFlg = False Then
    Sheets.Add , Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "抽出先"
End If
Sheets("抽出先").Visible = xlSheetVeryHidden
With Sheets("Sheet1")
    With .Range("A1", .Range("A" & Rows.Count).End(xlUp))
        MyA = .Resize(, 2).Value
        Set MytblA = .Resize(, 2)
    End With
End With
With Application
    最大値 = .Max(.Index(MyA, 0, 2))
End With
Application.ScreenUpdating = False
    With MytblA
        .AutoFilter
        .AutoFilter Field:=2, Criteria1:=最大値
    End With
    Sheets("抽出先").Cells.Clear
    With Sheets("Sheet1")
        .AutoFilter.Range.Copy Sheets("抽出先").Range("A1")
        .AutoFilterMode = False
    End With
Application.ScreenUpdating = True
Sheets("抽出先").Rows("1:1").Delete Shift:=xlUp
With Sheets("抽出先")
    With .Range("A1")
       MyB = .Resize(.CurrentRegion.Rows.Count).Value
        For i = LBound(MyB, 1) To UBound(MyB, 1)
            MyB(i, 1) = Format(MyB(i, 1), "yyyy/m/d")
        Next
        .Resize(.CurrentRegion.Rows.Count).Value = MyB
        Set MytblB = .Resize(.CurrentRegion.Rows.Count)
    End With
End With
For i = LBound(MyA, 1) To UBound(MyA, 1)
    検索日 = Format(MyA(i, 1), "yyyy/m/d")
    z = Application.Match(CLng(検索日), MytblB, 0)
    If Not IsError(z) Then
        k = k + 1
        ReDim Preserve MyAry(1 To 2, 1 To k)
        MyAry(1, k) = MyA(i, 1)
        MyAry(2, k) = MyA(i, 2)
    End If
Next
With Sheets("Sheet2")
    .Cells.Clear
    .Range("A1").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
End With
Set MytblA = Nothing
Set MytblB = Nothing
Erase MyA, MyB, MyAry
End Sub
（SoulMan） 2019/01/27(日) 14:04

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

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