[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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]] 『[談]シートレイアウトの投稿どうしてますか?』(momo)
↑のリンクにあるコードで、 1)最低でも2日分のデータ 2)出力結果 3)最大が複数日あった場合 を提示できますか?
今の状態だと、日付と時間が同じセルなのか、別のセルなのか、 数量もどの列にあるのかわかりません。
(稲葉) 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.