[[20190108133640]] 『年度毎の抜出や転記など』(はるはる) ページの最後に飛ぶ

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

 

『年度毎の抜出や転記など』(はるはる)

初めまして閲覧ありがとうございます。
早速ですが下記が案件となります。

G4:IS298の範囲に下記の関数を使ってデータを抜き出しています。

=IF(INDEX(確認!$H$4:$IT$2658,MATCH("使用開始日"&$E4,'Sheet1 (2)'!$C$4:$C$2931,0),MATCH(G$3,$G$3:$KT$3,0))=0,"",INDEX(確認!$H$4:$IT$2658,MATCH("使用開始日"&$E4,'Sheet1 (2)'!$C$4:$C$2931,0),MATCH(G$3,$G$3:$KT$3,0)))

データ量が多い為、重たくなってしまっていてマクロに置き換えることができないか悩んでいます。

場所
持出者名
使用開始日
返却予定
返却日
返却者名
修理送付日
修理依頼日
備考

が繰り返されているグループが300個程あります。
MATCH部分用にCOUNTIFを使て横に数字を入れて区別をしています。

Sheet1 (2)に転記先の表を作成しています。
G3〜IS3には1〜247
F4〜F298には通番で1〜

G4:IS298の範囲に関数で抜き出したデータが入っています。

確認シートには元になるデータが入っており、利用登録をすると別のマクロによって追加記載されていく仕様になっています。

Fに入っているものが貸し出し機材の通番になっています

最終的に
通番毎に年度で何回使用したかわかるリスト


番号   2016年度 2017年度・・・・
  1 3回
  2 0回
  3 1回
  4 1回
  ・
  ・
  ・
  ・

と、年度で使用場所毎に何回使用したかわかるリスト

2016年度←入力後マクロ起動ボタンを押す

番号    場所A 場所B 場所C・・・・・
  1 1回 1回 1回
  2 0回 0回 0回
  3 1回 0回 0回
  4 1回 0回 0回
  ・
  ・
  ・
  ・

上記表で該当する物だけを下記の表に表示しなおす

  F   G     H I J ・・・・

			1	2	3	・・・・
	場所	▲	▲	▲
	持出者名
	使用開始日	〇	〇	〇
  1	返却予定
	返却日
	返却者名
	修理送付日
	修理依頼日
____備考
	場所	▲	▲	▲
	持出者名
	使用開始日	〇	〇	〇
  2	返却予定
	返却日
	返却者名
	修理送付日
	修理依頼日
____備考

3種類のシートが作りたいです。
現在ほとんどを関数で組んでいる為ブックを開くだけでも一苦労でして…

マクロは簡単な並べ替えと転記しかできないのでご助力いただけたらと思います。
よろしくお願いします。

< 使用 Excel:unknown、使用 OS:Windows7 >


 なんとか解読しようとしてみましたが、?????です。
先ず、↓これは 0 だったら 空白 それ以外は、、、ですよね?

 =IF(INDEX(確認!$H$4:$IT$2658,MATCH("使用開始日"&$E4,'Sheet1 (2)'!$C$4:$C$2931,0),MATCH(G$3,$G$3:$KT$3,0))=0,"",
INDEX(確認!$H$4:$IT$2658,MATCH("使用開始日"&$E4,'Sheet1 (2)'!$C$4:$C$2931,0),MATCH(G$3,$G$3:$KT$3,0)))

 つまり、
INDEX(確認!$H$4:$IT$2658,MATCH("使用開始日"&$E4,'Sheet1 (2)'!$C$4:$C$2931,0),MATCH(G$3,$G$3:$KT$3,0))
これだけですよね?

 で、これは、E4 が日付だとして、、何で 使用開始日 とくっついているんですか?
ひょっとして、日付は 文字 ですか?

 その文字列を、、Sheet1 (2)'!$C$4:$C$2931の縦目から探すんですよね?

 で、
 >G3〜IS3には1〜247 
 MATCH(G$3,$G$3:$KT$3,0) ←これって、そのまんまじゃないですか?

 G3を G3からKT3の間で探すんでしょ?

 >通番毎に年度で何回使用したかわかるリスト

 となると、少なくとも 日付は シリアル値 の方が断然いいと思いますけど、どうでしょう?

 と、小言みたいになりますから、あまり言いたくはないんですけど、、、

 いきなり最終的な結果をここで求めてもトピ主さんの画面を見てるわけではないので限界があるんですよね

 そこに、↓となると、

 >データ量が多い為、重たくなってしまっていてマクロに置き換えることができないか悩んでいます。 

 相当ですよ(^^;

 もう少し質問内容をコンパクトにして取り敢えずヒントを得て、それを応用する←これがトピ主さんのするべきこと
 だと思うんですけど、どうでしょう???

 すみませんね 回答になってなくて、、、、また、お力になれる日が来るといいのにね
(SoulMan) 2019/01/09(水) 20:47

 と、これだけだと小言になるので、現段階で私なりに出来るアドバイスをまとめてみますと、

 1.基本は新規Bookです。
よく質問されて回答を得て、出来ません って方がいらしゃるでしょ?
いきなりご自身のBookで試したいのは分かりますけど、回答者の方も一応はテストしていらっしゃるだろうから
新規Bookで出来てご自身のBookで出来ないのは、トピ主さん側の問題であって回答者には分からないのです。
だから、質問の基本は 新規Book です。

 2.Excel的に見やすいのは、リストです。
今回のご質問で感じたことは、最終的にはデータをまとめる→管理されたいんだと思うのです。
そこで、Excel的に見やすいのはリストなんです。
リストつまり、
見出しがあって項目があってデータがずらずら〜〜と並んでるやつです。
人間的には見難くてもExcel的は一番見やすくて、リストから表というツールは沢山ありますが、
表からリスト→集計、、となるから話がややこしくなるのです。
印刷のレイアウトとか見た目と言うのは人間側の都合であって、、、Excel的には最悪なのです。

 >データ量が多い為、重たくなってしまっていて
 List形式で保存していれば、↑となるのは、よっぽどです。
 データは、別の場所に保存しておいて必要なデータだけを都度取り出すとか、、

 >年度毎の抜出や転記など
 何てのは、Excelの最も得意とする分野で
ハードルを上げるのも下げるのもトピ主さん自身なのです。
管理されたいのであれば、、List です。

 3.日付は、シリアル値 です。
これは、基本中の基本です。取り敢えず、シリアル値で入力してさえおけば、、表示するのは
極端な話、どうにでもなる←ちょっと言い過ぎ(笑)でも、まんざらでもない
文字にした日付をシリアル値に戻す方がよっぽど難しい

 以上、この3点を見直すだけでも随分と楽になると思います。

 Excelを100%とは言わない、50%、いや10%でも活用されたらほとんどの問題は出尽くしている←これまた言い過ぎ(笑)

 Excelを前にして電卓を叩く何てのは愚の骨頂でExcelは方眼紙でもなければワープロでもありません
 表計算ソフトですから、、、、

 と、まぁ、初老の小言でした。

 おやすみなさいzzzzzzzzzzzzzzzzzzzzz
(SoulMan) 2019/01/09(水) 22:02

SoulManさん

ご返信ありがとうございます
"使用開始日"&$E4の部分は

データベースになっているシートの
Eに通番が入っていて

使用場所
持出者名
使用開始日
返却予定
返却日
返却者名
校正送付日
修理依頼日
備考


別のシートで下記に変更しています。

場所1
持出者名1
使用開始日1
返却予定1
返却日1
返却者名1
校正送付日1
修理依頼日1
備考1
場所2
持出者名2
開始日2
返却予定2
返却日2
返却者名2
修理送付日2
修理依頼日2
備考2

データベース

   F   G     H I J ・・・・

			1	2	3	・・・・
	場所	▲	▲	▲
	持出者名
	使用開始日	〇	〇	〇
  1	返却予定
	返却日
	返却者名
	修理送付日
	修理依頼日
____備考
	場所	▲	▲	▲
	持出者名
	使用開始日	〇	〇	〇
  2	返却予定
	返却日
	返却者名
	修理送付日
	修理依頼日
____備考

この形のリストから

通番  機器番号    1       2       3       4       5
1     6            2015/10/2
2     7    2015/5/8    2016/5/19          2016/6/30   2016/9/26
3     8
4     9   2015/07/10    2015/10/26         2015/10/29   2015/11/30
5     10
6     11   2016/1/15    2016/2/12   2016/7/5
7     12   2015/06/5    2016/1/4   2016/2/11   2016/2/12   2016/2/22
8     13           2016/9/15   2016/9/29   2016/11/7   2016/11/18
9     14

参考シートに使用開始日のみ抜き出す為です。
空白を入れているのは、日付以外を表示させない為です。
数が多くてVLOOKUP等だと指定が大変だったので
INDEXとMATCHでやっているそうです。

ここから
=COUNTIFS('Sheet1 (2)'!$G4:$IS4,">="&C$3&"/4/1",確認!$H6:$IT6,"<="&C$3+1&"/3/31")
こちらを使って下記のカウントを行ています。
通番  機器番号    2015
1     6       1
2     7       0
3     8       0
4     9       0
5     10       0
6     11       0
7     12       0
8     13       0
9     14       0

> 1.基本は新規Bookです。

すみません。
えっと、まだ失敗したともできていないとも言っていないのでなんとも…。
ただ、ブックを分けすぎるとエクセルを使えない人たちがわからなくなってしまうので
余りむやみにブックを増やすのは嫌われますね。

> 2.Excel的に見やすいのは、リストです。
最終的に出来上がりの形が指定されてしまっていますので、
私自身で見やすさを求めることはできないです。
正直、なんでこんな面倒な形で作ったのだろうという疑問しかないので。
また、読み込みやリンクなどを使ってブックを分けると毎回破壊されているので基本的にはブックでまとめるかマクロを使って呼び出す形をとるようにしています。
今回の物も、参照がしやすかったり抜出がしやすい形で作られているのであればもう少し調べてでもできたとは思いますが、
その日にちが範囲内であればそのグループ転記するといった方法がわからない為ご相談しました。

> 3.日付は、シリアル値 です。

日付は、シリアル値です。

説明が下手ですみません。
これでもなるべくまとまるようにと元のエクセルブックデータを整理したのですが、
作った方がもういないので聞くこともできず探り探りで自分も適切に質問をすることができていないのが現状です。

ブック解読を進めながら気長に質問・回答をいただける方を待とうと思います。
(はるはる) 2019/01/10(木) 19:07


 こんばんは!
以前、↓このトピの中で半平太さんが再現しているのを見ていいなぁ、、
と思って私なりに書き換えたコードがあるんですけど、、試してみますぅ??

[[20180331225641]]

 その時は、動いたと思うので大丈夫だと思うのですが、駄目だったらごめんなさいm(__)m

 取り敢えず、そのデータベースというシートをこちらで再現してみましょうか?

 ネットに載ってまずいデータは、別の項目に置き換えておいてくださいね。

 そういう意味では、新規Bookです。

 私の言う新規Bookとは、トピ主さんの現状のBookではなくてお互いが共有できるBookのことです。

 >ブック解読を進めながら気長に質問・回答をいただける方を待とうと思います。

 なんか危険な領域に足を踏み入れた気がします。。。。。よっぉ!SoulMan!久しぶりにSwitchOnかぁ???(あおるな←すみません。ひとり言です。)

 私の能力でことが足りればいいんですけどね(^^; フォローをお願いしますよ!特に○○さん!!!
 今、ドッキとされたあなた!あなたですよ!!(笑)

 この↓コードをそのデーターベースSheetのシートモジュールに張り付けてF5を押して実行
そのまま、ここへ(学校の掲示板)張り付けて下さい。

 Option Explicit
Sub お題作成最終版しっかり頼むぜSoulMan今度こそ()
Dim x() As Variant
Dim 結果 As Variant
Dim MyTbl As Range
Dim r As Range
Dim ws As Worksheet
Dim k As Long
Dim i As Long
Dim MyFlg As Boolean
Dim MyFlgA As Boolean
Const 塗つぶしセル As String = "  Range(""MyAdr"").Interior.ColorIndex = "
Const 値セル As String = "  Range(""MyAdr"").Value = "
Const 数式セル As String = "  Range(""MyAdr"").FormulaR1C1Local = "
Const 文字列セル As String = "  Range(""MyAdr"").NumberFormatLocal = ""@"""  '文字列(頭が「’」のデータ処理
Const 表示形式 As String = "  Range(""MyAdr"").NumberFormatLocal = "       '標準外の表示形式
Const 列幅 As String = "  Range(""MyAdr"").ColumnWidth = "
Const 行高 As String = "  Range(""MyAdr"").RowHeight = "
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
Set MyTbl = Me.UsedRange
k = 0
With Sheets("抽出先")
    ReDim Preserve x(k)
    x(k) = " Private Sub SoulMan()"
    k = k + 1
    ReDim Preserve x(k)
    x(k) = " Rem 結合状態を処理"
    For Each r In MyTbl
        '結合セルで
        If r.MergeCells Then
            '左端上と同じだったら
            If r.Address = r.MergeArea.Item(1).Address Then
                k = k + 1
                ReDim Preserve x(k)
                x(k) = " Range(""" & r.MergeArea.Address(0, 0) & """).Merge"
            End If
        End If
    Next
    k = k + 2
    ReDim Preserve x(k)
    x(k) = " Rem 数式セル以外をまとめて処理"
    MyFlgA = False
    結果 = まとめて処理(MyTbl, 値セル, MyFlgA, "値")
    If MyFlgA Then
        For i = LBound(結果) To UBound(結果)
            If 結果(i) <> Empty Then
                結果(i) = Replace(結果(i), vbLf, """ & Chr(10) & """)
                k = k + 1
                ReDim Preserve x(k)
                x(k) = 結果(i)
            End If
        Next i
    End If
    k = k + 2
    ReDim Preserve x(k)
    x(k) = " Rem 数式セルをまとめて処理"
    MyFlgA = False
    結果 = まとめて処理(MyTbl, 数式セル, MyFlgA, "数式")
    If MyFlgA Then
        For i = LBound(結果) To UBound(結果)
            If 結果(i) <> Empty Then
                k = k + 1
                ReDim Preserve x(k)
                x(k) = 結果(i)
            End If
        Next i
    End If
    k = k + 2
    ReDim Preserve x(k)
    x(k) = " Rem 標準外書式セルをまとめて処理"
    MyFlgA = False
    結果 = まとめて処理(MyTbl, 表示形式, MyFlgA, "セル書式")
    If MyFlgA Then
        For i = LBound(結果) To UBound(結果)
            If 結果(i) <> Empty Then
                k = k + 1
                ReDim Preserve x(k)
                x(k) = 結果(i)
            End If
        Next i
    End If
    k = k + 2
    ReDim Preserve x(k)
    x(k) = " Rem 塗りつぶしセルをまとめて処理"
    MyFlgA = False
    結果 = まとめて処理(MyTbl, 塗つぶしセル, MyFlgA, "塗りつぶし")
    If MyFlgA Then
        For i = LBound(結果) To UBound(結果)
            If 結果(i) <> Empty Then
            k = k + 1
            ReDim Preserve x(k)
            x(k) = 結果(i)
            End If
        Next i
    End If
    k = k + 2
    ReDim Preserve x(k)
    x(k) = " Rem 列幅をまとめて処理"
    MyFlgA = False
    結果 = まとめて処理(MyTbl, 列幅, MyFlgA, "列")
    If MyFlgA Then
        For i = LBound(結果) To UBound(結果)
            If 結果(i) <> Empty Then
            k = k + 1
            ReDim Preserve x(k)
            x(k) = 結果(i)
            End If
        Next i
    End If
    k = k + 2
    ReDim Preserve x(k)
    x(k) = " Rem 行高さをまとめて処理"
    MyFlgA = False
    結果 = まとめて処理(MyTbl, 行高, MyFlgA, "行")
    If MyFlgA Then
        For i = LBound(結果) To UBound(結果)
            If 結果(i) <> Empty Then
            k = k + 1
            ReDim Preserve x(k)
            x(k) = 結果(i)
            End If
        Next i
    End If
    k = k + 1
    ReDim Preserve x(k)
    x(k) = "  MsgBox ""お題の作成が完了しました。"""
    k = k + 2
    ReDim Preserve x(k)
    x(k) = " End Sub"
    .Cells.Clear
    .Range("A1").Resize(UBound(x) + 1).Value = Application.Transpose(x)
    .Range("A1").Resize(UBound(x) + 1).Copy
End With
Set MyTbl = Nothing
If IsArray(結果) Then Erase 結果
If IsArray(x) Then Erase x
MsgBox "処理が完了しました。" & vbCrLf & vbCrLf & _
        "そのまま張り付けて下さい。"
End Sub
Private Function まとめて処理( _
    ByVal MyTbl As Range, _
    ByVal MyStr As String, _
    ByRef MyFlgA As Boolean, _
    Optional ByVal 条件 As String = "値") As Variant
Dim MyDic As Object
Dim r As Range
Dim 結果() As Variant
Dim 探索 As Variant
Dim MyItem As Variant
Dim x As Variant
Dim z As Variant
Dim MyKey As Variant
Dim MyStrA As String
Dim MyAdr As String
Dim 探索結果 As String
Dim k As Long
Set MyDic = CreateObject("Scripting.Dictionary")
For Each r In MyTbl
    MyItem = Empty
    Select Case 条件
        Case "値"
            If Not r.HasFormula And Not IsEmpty(r.Value) Then
                MyItem = IIf(IsError(r.Value2), r.Formula, r.Value2)
            End If
        Case "数式"
            If r.HasFormula Then
                MyItem = r.FormulaR1C1Local
            End If
        Case "セル書式"
            If r.NumberFormatLocal <> "G/標準" And _
                TypeName(r.Value) <> "Currency" Then '標準外の書式を反映させる。通貨型は面倒なので処理外
                MyItem = r.NumberFormatLocal
            End If
        Case "塗りつぶし"
            If r.Interior.ColorIndex <> -4142 Then '塗りつぶしがあるセルを処理
                MyItem = r.Interior.ColorIndex
            End If
        Case "列"
                MyItem = r.ColumnWidth
        Case "行"
                MyItem = r.RowHeight
    End Select
    If Not IsEmpty(MyItem) Then
        If MyDic.Exists(MyItem) Then
            x = Split(MyDic(MyItem), "#")
            MyStrA = x(0) + 1
            MyDic(MyItem) = MyStrA & "#" & x(1) & r.Address(0, 0) & " "
        Else
            MyDic.Add MyItem, "1#" & r.Address(0, 0) & " "
        End If
    End If
Next
z = MyDic.Keys
If UBound(z) > -1 Then
    MyFlgA = True
    ReDim 結果(0 To UBound(z))
    k = 0
    For Each MyKey In MyDic.Keys
        x = Split(MyDic(MyKey), "#")
        MyAdr = Replace(RTrim(x(1)), " ", ",")
        MyAdr = アドレスを結合(MyAdr) 'バラバラのAddressを統合
        For Each 探索 In Split(MyAdr, "#!#")
            If 探索 <> "" Then
                探索結果 = IIf(Application.IsText(MyKey), """", "") & _
                    Replace(MyKey, """", """""") & _
                        IIf(Application.IsText(MyKey), """", "")
                探索結果 = Replace(MyStr, "MyAdr", 探索) & 探索結果
                k = k + 1
                If k - 1 > UBound(結果) Then
                    ReDim Preserve 結果(0 To k - 1)
                End If
                結果(k - 1) = 探索結果
            End If
        Next
    Next
End If
まとめて処理 = 結果
Set MyDic = Nothing
If IsArray(z) Then Erase z
If IsArray(x) Then Erase x
End Function
Private Function アドレスを結合(ByRef MyAdr As String) As String 'バラバラのAddressを統合
Dim 対象範囲 As Range
Dim 主アドレス As String
Dim 行アドレス As String
Dim 列アドレス As String
    Set 対象範囲 = Range(Split(MyAdr, ",")(0))
    主アドレス = "," & MyAdr & ","
    Do While Not 対象範囲 Is Nothing
        行の統合 対象範囲, 主アドレス
        行アドレス = 行アドレス & 対象範囲.Address(0, 0) & ","
        If Len(主アドレス) < 4 Then
            Set 対象範囲 = Nothing
        Else
            Set 対象範囲 = Range(Split(主アドレス, ",")(1))
        End If
    Loop
    Set 対象範囲 = Range(Split(行アドレス & ",", ",")(0))
    主アドレス = "," & 行アドレス
    Do While Not 対象範囲 Is Nothing
        列の統合 対象範囲, 主アドレス
        列アドレス = 列アドレス & 対象範囲.Address(0, 0) & ","
        If Len(主アドレス) < 4 Then
            Set 対象範囲 = Nothing
        Else
            Set 対象範囲 = Range(Split(主アドレス, ",")(1))
        End If
    Loop
    アドレスを結合 = 小分け(列アドレス) '10セル以上は長いので同じ構文でも分割作成
End Function
Private Function 小分け(ByVal MyAdr As String) As String
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim n As Double
Dim k As Double
Dim i As Long
    y = Split(MyAdr, ",")
    i = UBound(y)   '対象個数
    k = Int((i - 1) / 10) + 1
    k = Application.RoundUp(UBound(y) / k, 0) 'まとめるアドレスの数
    For n = 0 To i - 1 Step k
        z = 連結(n, Application.Min(i - 1, n + k - 1), y)
        x = IIf(x = "", z, x & "#!#" & z)
    Next n
    小分け = x & "#!#"
End Function
Private Function 連結(ByVal 開始 As Long, ByVal 終了 As Long, ByVal MyA As Variant) As String
Dim k As Long
Dim MyStr As Variant
    MyStr = MyA(開始)
        For k = 開始 + 1 To 終了
            MyStr = MyStr & "," & MyA(k)
        Next k
    連結 = MyStr
End Function
Private Sub 行の統合(ByRef 対象範囲 As Range, ByRef 主アドレス As String)
Dim x As Variant
    x = Split(主アドレス, ",")
    主アドレス = Replace(主アドレス, "," & x(1) & ",", ",") 'アドレス文字列から除外
    If Range(x(1)).Cells(1, 2).Address(0, 0) = x(2) Then '右横に同じものあり
        Set 対象範囲 = Range(対象範囲, Range(x(2)))
        行の統合 対象範囲, 主アドレス
    End If
End Sub
Private Sub 列の統合(ByRef 対象範囲 As Range, ByRef 主アドレス As String) '直下が同じ範囲かチェック
Dim x As Variant
Dim MyAdr As String
    x = Split(主アドレス, ",")
    主アドレス = Replace(主アドレス, "," & 対象範囲.Rows(対象範囲.Rows.Count).Address(0, 0) & ",", ",") 'アドレス文字列から除外
    MyAdr = 対象範囲.Rows(対象範囲.Rows.Count + 1).Address(0, 0) '結合セル対策
    If 主アドレス Like "*," & MyAdr & ",*" Then   '真下に同じものあり
        Set 対象範囲 = Range(対象範囲, Range(MyAdr))
        列の統合 対象範囲, 主アドレス
    End If
End Sub
(SoulMan) 2019/01/10(木) 20:42

 横入りすみません。
SoulManさん
すごいですね。^^v

 私も作りたいと挑戦はしているのですが。。。くじけています。^^
勉強させて戴きます。
はるはる さん
おじゃまして
済みませんでした。
m(_ _)m
(隠居じーさん) 2019/01/10(木) 21:28

SoulManさん

ありがとうございます!
名前等の書き換えをしながら作ってきます!

急ぎで別の資料作成依頼が来てしまったので週明けになってしまいます、、、
お時間が空いてしまうのですが待っていただけると嬉しいです。

隠居じーさんさん
みなさん十分すごいと思います。。。。
色々といい案があれば教えていただければと思いますのでよろしくお願いします。
(はるはる) 2019/01/11(金) 15:22


 すみません。

 ちょっと気になったので家に帰ってからよくよくコードを探したら、昨日のコードより新しいコードがありました。

 正直、自分でもどこがどう違うのかは一年くらい前のことなので全然覚えていません。

 でも、不都合があったから修正したんだと思うんです。

 私のPCの中にはこんなサンプルコードがごちゃごちゃ〜〜〜とあるので、、、無精なんですね(^^;

 すみません。

 上のコードを張り替えておきましたので差し替えてください。

 では、では、
(SoulMan) 2019/01/11(金) 21:27

SoulManさん

お世話になっております。
コードを実行してみたのですが、

インディックスが有効範囲にありません

というエラーが出てしまいました。。。
(はるはる) 2019/01/16(水) 10:10


 すみません
駄作だったみたいです(^^;;

 そのエラーが出ているところをここへ貼る事は出来ますか?

 ちょっと調べてみます
(SoulMan) 2019/01/16(水) 12:37

 と言うか、私の駄作コードで
悩んでも仕方ないので
今回は、リンク先の半平太さんの
コードをお借りして話を先に進めましょうか?
(SoulMan) 2019/01/16(水) 13:22

 こんにちは ^^
もしなんとかなればと。。。多分。。。多分ですが
二巡目の
z = MyDic.Keys
のzが
 -1
で
Excel様がお怒りかと
黄色い帯はでません。
ポッアップが出ます。
インディックスが有効範囲にありません 
実行時エラー9
でしたよ。
でも
一番最初の(修正前)の動作確認したとき
動いていましたので
(隠居じーさん) 2019/01/10(木) 21:28をアップしました。
わたしもすぐ、新規の
SoulManさんのコードに置き換えましたので以前の物は
消えています。
半平太先生のコードなら退避していますよ
実験代行マン
でした^^;
m(_ _)m

(隠居じーさん) 2019/01/16(水) 14:27


SoulManさん

インディックスが有効範囲にありません

というコメント以外特にエラー表示があるわけではないのですが、デバッグで確認すればいいのでしょうか?
バグチェックができるという事がなんとなく知っている程度で使用したことがないので…
(はるはる) 2019/01/16(水) 14:34


 隠居じーさん 様←もう神様扱いです。(笑)

 上のコードを最初のコードに差し替えておきましたのでお試し下さい。
(SoulMan) 2019/01/16(水) 14:44

 >>上のコードを最初のコードに差し替えておきましたのでお試し下さい。
>>(SoulMan) 2019/01/16(水) 14:44
で、いま貼り付けたコードのような構成の表ではエラー無く上記コードが生成されました
一方

     A          B           C          D            E           F        G          H            I            J     
  1  機材番号   使用場所    持出者名   使用開始日   返却予定    返却日   返却者名   校正送付日   修理依頼日   備考  
  2      10001  Aサーバー   カラフ        2019/1/2   2019/3/21           カラフ                               USB   

 上記の表では同じエラー内容となります。
違いと云えば
マージセルが有るか無いかくらいなのですが
原因究明には至っておりません。
トピ主さまの表は
あまり複雑なものではないのかもしれませんね。^^;
また推測だけでしかられそぉですが m(_ _)m

 なお、使用情報は以前こちらでアップ(公開)されていたものを
使わせていただきました。

(隠居じーさん) 2019/01/16(水) 15:06


 お騒がせしてます。すみません。

 どうもなかった時の対応を記述してなかったみたいです。_| ̄|○

 上のコードを差し替えておきました。

 対策としては、もう一つフラグを追加して まとめて処理 のところへ乗っけました。

 これで大丈夫だと思います。タイトルもちょっと気合を入れて

 Sub お題作成最終版しっかり頼むぜSoulMan()

 こうしておけば今後、間違えることもないでしょう????←もうちょっと真面目にやれぇ〜〜〜!!!(ここ笑うところですよ)

 前途多難な予感がしてきましたね(^^;

 お願いしますよ!今、ドッキっとされたあなた! あなた!! 頼りにしてますから、、、

 では、では、気長に行きましょうね? はるはる さん(;^_^A
(SoulMan) 2019/01/16(水) 16:43

 SoulManさん
すごいです。!
かんぺき
^^v

(隠居じーさん) 2019/01/16(水) 16:51


お世話になっています!
お時間をいただいていてすみません!

実行してから長い時間応答無状態が続くので仕事中になかなか実行できず…
もう少々お時間をいただければと思います。

申し訳ありません。
(はるはる) 2019/01/16(水) 16:57


 とんでもございません。こちらこそ何度もすみません。(私はいつもこんなもんです(^^;)

 また、間違ってましたから、、、 0以上かと思ったら 0 でもあるんですね?( ̄▽ ̄;)

 If UBound(z) > -1 Then

 にしておきました。

 >実行してから長い時間応答無状態が続くので仕事中になかなか実行できず… 

 データ量が多いんだと思います。

 基本形がわかればいいので、、、これを増やしてください。。ってな感じで、、、こちらで増やすだけなら増やしますから、、、

 データ量は最小限でいいです。

 では、では、今日は、たまたま、昼からお休みでしたけど、普段は夜中しかみてませんから、、、

 ゆっくり、、、いきましょうね
では、では、、、
(SoulMan) 2019/01/16(水) 17:25

 SoulManさんのコードも完成されたみたいですし。
(隠居じーさん) 2019/01/16(水) 15:06 の
私の実験出力コードは直接関連は無さそぉですので削除修正いたしました。
お邪魔致しました。
m(_ _)m
でわ

(隠居じーさん) 2019/01/16(水) 17:32


 隠居じーさん 様 いつも本当にありがとうございます。m(__)m

 凄く助かっています。このトピは、どうも長くなったので三人のデスマッチぽいですよ(笑)

 SoulManちゃんもねじれはちまきで頑張っちゃいまぁ〜〜〜す v(=∩_∩=)v
(SoulMan) 2019/01/16(水) 17:44

そうおっしゃっていただければ光栄です。
お邪魔にならない程度に(っていいながらおじゃまばかりしていますが^^;)
勉強させて戴きます。

(隠居じーさん) 2019/01/16(水) 18:04


お疲れ様です。

昨日実行してそのまま置いて帰ったのですが、、、、
文字領域が足りませんって言うエラーメッセージが…
(はるはる) 2019/01/17(木) 14:47


 すみません
データを絞ってください
100行くらいから増やして行って
イメージがわかる範囲でいいですから、。
すみません
(SoulMan) 2019/01/17(木) 14:54

 又は、新規bookに100行づつ
コピーしてもいいですけど、
100行くらいだったら何とかなると思うんですけど?
(SoulMan) 2019/01/17(木) 15:05

 遅くなりました
100行以下を削除して作成しましたが、こちらでよろしいでしょうか?

 End Sub

(はるはる) 2019/01/17(木) 16:53


作成しようとしているシートの方も念の為、2種類記載させていただきます。
長くなりすみません

表示リスト1

表示リスト2

(はるはる) 2019/01/17(木) 17:31


 こんばんは!
 やっとスタートラインに立てたって感じですね(^^;
 先ず、文字化けしているところから修正しましょう。

 ↓これらは何と書いてあるのですか?
 ?@"
 "?@と同様ですがさらに細かく使用機場名毎にが追加されます。"
 "?@のリストのセルC3に入力された年(今回は2015)をキーにして"
 ?Aの機場名は
 ?B

 >入る可能性がある機場名は基本的にメモシートのDL〜DQにある名前と校正です

 メモシートはどれですか?

 >ボタンを押したら残り二つのシートも同時に変更できると助かりますが、

 シートの構成は、

 データベース

 表示リスト  表示リスト1が表示リスト ですね? 表示リスト2 は何というシートですか?

 メモシート ?

 みたいですけど、、、

 後、データベースのシートはあの調子で何行くらいあるのですか?
 100万行って言わないでくださいよ(笑)

 取り敢えず、以上でしょうか??

 また、わからないことがあったらお聞きします。

 正直、まだ、イメージがわいてません。。。。m(__)m
(SoulMan) 2019/01/17(木) 20:32

				2015年度使用機場別回数				
 通番	機器番号	2015	機場名→	A1	A2	A3	E1	E2←これが
1	6	1	回数↓	1				
2	7	0		0				
3	8	0		0				

 データベースの
使用機場名	〇〇	〇〇	←ここに入るんじゃないんですか?
持出者名	〇〇	〇〇	
使用開始日		2015/10/2	
返却予定		2016/9/1	

 あと、↓この辺の数字は今回のご質問と関係ないのですか?
 		フラグ:1使用中、2返却済み、3校正中、4修理中、5予約		

 通番	機器番号	       使用回数	         カウント	フラグ
1	  6	     1	      2	     2
2	  7	     21	      24	     2
3	  8	     0	      0	     2
4	  9	     20	      24	     2
5	  10	     0	      0	     2
6	  11	     14	      19	     1
7	  12	     58	      61	     2
8	  13	     21	      24	     2
9	  14	     0	      0	     2
(SoulMan) 2019/01/17(木) 20:53

 あっ、それから最初にも申し上げた様にご質問の基本は新規bookです
ご自身のbookの事は忘れて
このコードで再現されたbookを基準にお話ししてくださいね
で、その新規bookでもしも出来て、
ご自身のbookで出来ないのは別の問題があるのでしょうから
それは、今回のご質問とは別と言う事だと思うのです
この新規bookからご自身のbookに移植する際の手間?は、ご自身でお願いしますよ
もしも、その労力がかけなれないのであれば、最初からやめておいた方がいいのかもしれませんよ?
(SoulMan) 2019/01/17(木) 21:53

わたしも気になってちょいちょい見てるけどなんか難しい方向に話が進んでいるような・・
とりあえず、SoulManさんがおっしゃっているように、データはレコード形式(縦方向に延びていく)ようにしたほうがいいでしょうね。

現状のレイアウトが今一つわかりませんが、

 【確認】シート
 ____F_____G____________H___________I_________H_______
  1    使用場所     A会議室    A会議室    B会議室
  2    持出者名     aaaa       bbbb       aaaa
  3    使用開始日   2019/01/01 2019/01/02 2019/01/04
  4    返却予定     2019/01/01 2019/01/05 2019/01/10
  5  1 返却日       2019/01/01 2019/01/03
  6    返却者名     aaaa       bbbb
  7    校正送付日
  8    修理依頼日
  9    備考

 10    使用場所     B会議室    C会議室
 11    持出者名     aaaa       bbbb
 12    使用開始日   2019/01/15 2019/01/17
 13    返却予定     2019/01/16 2019/02/01
 14  2 返却日       2019/01/17
 15    返却者名     aaaa 
 16    校正送付日
 17    修理依頼日
 18    備考

 ※ F1:F9、F10:F18....はセル結合されている

とりあえず、↑こんな感じだったとしたら
↓のような形にかえることをかんがえてみてはいかがでしょうか。

 【データベース】シート
______A________B________C_________D__________E__________F_________G__________H__________I_______J___
  1 機器番号 使用場所 持出者名 使用開始日 返却予定   返却日     返却者名 校正送付日 修理依頼日 備考
  2    1     A会議室  aaaa     2019/01/01 2019/01/01 2019/01/01 aaaa   
  3    1     A会議室  bbbb     2019/01/01 2019/01/05 2019/01/03 bbbb   
  4    1     B会議室  bbbb     2019/01/04 2019/01/10
  5    2     B会議室  aaaa     2019/01/15 2019/01/16 2019/01/17 aaaa   
  6    2     C会議室  bbbb     2019/01/17 2019/02/01  
  7
  8

↑のようにしてしまえば、このデータをソースにピポットテーブルを作成しお望みのようなものができると思います。

次投稿へつづく

(もこな2) 2019/01/17(木) 22:41


つづき。
上記のように変更するには、行列入れ替えならがコピペするだけでしょうけど、機器が300台もあったら大変だとおもうので、↓のようなマクロを作ってしまうのもよいかもしれません。
    Sub さんぷる()
        Dim i As Long
        Dim dstSH As Worksheet
        Dim tmpRNG As Range

        On Error Resume Next
        Set dstSH = Worksheets("データベース")
        On Error GoTo 0
        If dstSH Is Nothing Then
            Set dstSH = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            dstSH.Name = "データベース"
        Else
            dstSH.Cells.Delete
        End If

        dstSH.Range("A1:J1").Value = Array("機器番号", "使用場所", "持出者名", "使用開始日", "返却予定", "返却日", "返却者名", "校正送付日", "修理依頼日", "備考")

        With Worksheets("確認")
            For i = 1 To .Cells(.Rows.Count, "F").End(xlUp).Row Step 9
                If .Cells(i, .Columns.Count).End(xlToLeft).Column >= 8 Then
                    With .Range(.Cells(i, "H"), .Cells(i + 8, .Cells(i, .Columns.Count).End(xlToLeft).Column))
                        .Copy
                        dstSH.Cells(dstSH.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial Transpose:=True
                        dstSH.Cells(dstSH.Rows.Count, "A").End(xlUp).Offset(1).Resize(.Columns.Count) = .Parent.Cells(i, "F").Value
                    End With
                End If
            Next
        End With

    End Sub

複雑に見えるかもしれませんが、ほぼ行列入れ替えて貼り付けてるだけです。

(もこな2) 2019/01/18(金) 02:30


SoulManさん

おはようございます。

>?@" 
?@?A?Bという表記だと思います(マル1、マル2、マル3)

>メモシートはどれですか?
今回は入れていません。
前に作った方がマクロの参照等に使っているシートなのですが、
その中に場所一覧があります

新規ブックにシート貼り付けしたので、元のブックに記載されている指示も記載されていてメモとなっています。
必要があればそちらも目隠しや一部削除の上、新規ブックにします。

>シートの構成
新規ブックでのシート構成は

データベース1
表示シート
表示シート2

です。

>データベースのシートはあの調子で何行くらいあるのですか?

現時点で、機器300台分までの物と
その下にまばらにある意味を成しているかわからない情報の記載も含めると
59665行になっています。

>←ここに入るんじゃないんですか?

こちらには既に入力されています。
元のブックでの作業になりますが

機器を使用する

入力用マクロに入力する

データベース1に入力される

現在、元のブックではデータベース1が閲覧用データになています。
(全体の使用履歴一覧)

それとは別に

・機器毎の年度別使用回数
・機器毎、使用場所毎の年度別使用回数
・データベース1と同じ表示の年度別表示

の3つが欲しいそうです。

○○の部分は人の名前やA1、A2…と仮記載したものが入りますが
場所毎に入れ替えが時間的に難しかったのでまとめて〇〇に変えてしまいました。

>↓この辺の数字は今回のご質問と関係ないのですか?
今回の物には必要ないかと思います。
データベース1のシートをそのまま新規ブック化したので
もしかすると、データベース1を作成するのに必要な情報の可能性があります。

取り急ぎの返信になってしまい申し訳ありません

(はるはる) 2019/01/18(金) 09:56


もこな2さん

ありがとうございます。
自分も蓄積データはそのようにした方がいいと提案はしているのですが、
閲覧を兼ねている事と
元々あるマクロでデータベース1になるような形への転記になってしまうので前の方の作ったマクロ内容の解読ができていないので変更ができません。

最終的に
データベース1
表示シート
表示シート2

この3つにある一覧表が完成できれば大丈夫なようなので
間で蓄積データ用のシートをかませてもいいのかもしれませんが

入力

蓄積用シート

データベース1
表示シート
表示シート2

にする場合、入力フォームのマクロを変更する必要が出てきてしまいます。

入力

データベース1

蓄積用シート

表示シート
表示シート2

にする場合、データベース1から蓄積用シートへの転記作業が必要になると思うのですが
手動作業が入ると一部の人以外が作業できなくなる可能性があります。

皆様
色々と考えていただき本当に皆様ありがとうございます。
(はるはる) 2019/01/18(金) 10:10


SoulManさん

すみません。
少し勘違いをしていたので追加で記載させていただきます

>←これが
>←ここに入るんじゃないんですか?

の部分ですが
←ここに入るんじゃないんですか?
に、元ブックマクロで入力フォームから転記されます。

←これが

の部分に、
可能であれば指定年度内に使用されている場所のみをデータベース1からピックアップして抜き出す
不可能なら使用する場所すべてを入力しておく。という形にしたいです。

元から入力しておく場合は
今年度までで75か所になり、以降も増える可能性があります。

わかりにくかったらすみません。

元データのメモシートに下記の様に場所の一覧が記載されています。

(はるはる) 2019/01/18(金) 10:29


 こんばんは!

 このトピが長くなるのは分かっていましたし、既に長くなっていますが、 急がば回れ!です。ここで一旦、整理しましょう。

 >?@?A?Bという表記だと思います(マル1、マル2、マル3) 

 機種依存のマル1、マル2、マル3のことだと思うのですが、文字化けしますから使わない様にしましょう。

 >必要があればそちらも目隠しや一部削除の上、新規ブックにします。 

 あのぉぉ、、、よぉぉぉ〜〜〜く考えてくださいよ

 必要なんですか?必要じゃないんですか?それを決めるのはトピ主さんなんじゃないんですか????

 シートの構成は理解できました。

 >59665行になっています。

 データ量も理解出来ました。

 問題は、ここです。

 >それとは別に 

 >・機器毎の年度別使用回数 
 >・機器毎、使用場所毎の年度別使用回数 
 >・データベース1と同じ表示の年度別表示 

 >の3つが欲しいそうです。 

 ってトピ主さんはあなたじゃないんですか????

 >○○の部分は人の名前やA1、A2…と仮記載したものが入りますが 
 >場所毎に入れ替えが時間的に難しかったのでまとめて〇〇に変えてしまいました。 

 あのぉぉ、、単純にシンプルにいきましょう。。。

 データベースがある→必要なデータを抜き取る ですよね? 一言で言えば、、、、

 データデースにないものが結果を表すシートに出てきたら、これはどこから来たの?となりませんか?

 私は、私の三つ目の投稿の時に、

 >なんか危険な領域に足を踏み入れた気がします。。。。。

 と言いましたが、、、回答者みたいなことをながくやってるとなんとなくわかるんですよ。。

 失礼ですけど、、的を得ていないんです。ピントがずれているんです。(ちょっと言い過ぎました。でも、他に表現がみあたりません。)

 こういった掲示板というところは、例え話をするところだと私は思っていて、

 例えば、、例をあげて この表を→こうしたい ただそれだけなんですよ。

 で、そのルールを決めるのも、その答えを決めるのも、、トピ主さん、、なんですよ

 いくら回答者が、、、〇●だと言っても トピ主さんが違うと言えば、違うし、合ってると言えば合ってる

 そんな世界なんですよ。わかりますか?

 私は、私の二回目の投稿の時に、実は、このトピは最後だなと思って投稿しました。

 でも、日付がシリアル値だったので、、それならなんとかなると思って続けました。

 それから、くどいようですけど、ご自身のBookの説明はもういいです。

 読んでもわかりませんし、疲れるだけです。

 と言うのは、ここで私が書いたコードをそのままご自身のBookにあてはめても動くとは思えませんし、

 私も何とかトピ主さんのお力になりたいと思いますけど、、それは土台、無理な話なんですよ。

 だって見えないんですから、、、そのBookの情報を全て共有することなど、無理なんです。そう思いませんか????

 だから共通のBookで例え話をしましょう→そこから応用してくださいね。

 という流れのつもりだったんです。わかりますか?熟読してくださいよ。

そこに、、だそうです。。。となると、、丸投げ感、満載なんですよ。

 私は、別にコードを書くことは苦じゃなくて自分自身の為に書いていて、、私のコードに対して

「出来ました」と言われても、、当然、、実用段階では応用されているんだろうなぁ、、、と思っています。

 それから、次回、トピ主さんがこのトピに投稿する前には他のトピを10件ほど見てから投稿された方がいいと思いますよ。

 質問下手で損を、不利益をえるのは、結局、トピ主さんなのですから、、、、

 私は、このトピに対して一行もコードを書いてないのです。というかぁ、、何をどう書いていいのか分からないのです。

 勘違いしないでくださいよ。難しいんじゃなくて何をどうされたいのかさっぱりわかないのです。

 言葉の説明などいらないのです。

 Before→After なぜ?そうなるのか? 正しい結果は、これ!

 ただ、それだけなのです。

 データベースのシートも22行目から下はいらないです。

 それよりも、どこをどう見てこのデータベースのシートからなぜ?この結果が導かれるのか?この一点でしょ?

 そう思いませんか?

 必要なのはシートのレイアウトとか、、検索するKeyとか、、ご自身では当たり前のことでも回答者には分からないのです。

 ご自身でコードは書けないにしても何がどうで、、、だから、、、この結果になる。。この結果が欲しい。だけでしょ。

 せっかく Sub お題作成最終版しっかり頼むぜSoulMan今度こそ() という中途半端なツールもあるのですから、

 そこで出たコードを違うシートのモジュールに張り付けて ▶ を押せば私と同じ環境になります。

 必要なデータは、色を付けてもいいですし、、工夫できることは沢山あると思いますよ。

 シートのレイアウトを崩してコメントをいれるのは最低最悪です。なんの為にBookを共有しているのかわかりません。

 ご自身のBookを何とかしたいお気持ちは分かりますが、先ずは、、一つづついきましょう。

 といってもこの次、私からの回答がなかったらそういう事だったと思ってください。

 私は途中で投げ出したことはない?と自分では思っているのですが、、(あったらごめんなさい)今回はちょっと、、、???かもです。

 すみません。m(__)m

 私が回答出来るのは、平日なら寝る前の1.2時間、、、23時過ぎ、、、普段は無理です。

 週末も、、、時々なので、、、、

 トピ主さんがこの私のトピを熟読されて次の行動をとられてより良い回答が得られることを切に願っています。

 しっかりした お題 さえ表現出来れば、、、理屈、、原理、、、ルールさえわかれば何でもない お題 だと思います。 

 私が、現段階でトピ主さんにアドバイスできるのはこれくらいかなと思います。

 では、では、
(SoulMan) 2019/01/18(金) 21:36

 と、このままだと、私の記憶史上初の投げ出しとなるのと

 元々、私は自分だったらどうする?というスタイルなので、、トピ主さんが誰とかあんまり関係なく、この間は言い過ぎました。すみません。

 で、もうトピ主さんは帰ってこられないかもしれませんが、このトピにはどうしても解決して欲しい理由があるので私なりに考えてみました。

 表示シート2 の方は意外と簡単で、、A列とB列に機器番号と項目と言いますか、、フィールド?があらかじめ記入されているとして

 データベースから該当の機器番号の開始日がその年度内にあるデーターを持ってきます。

 これは、データーベースのシートを100002行まで拡張しても表示シート2の方が10件程なら、418.797秒程でした。

 ただ、ディクショナリーでデーターベースの方をなめてますから、重複した機器番号があると下の方にある機器番号のデーターが優先されます。

 区別する必要があるのなら、機器番号は固有の機器番号を使用する必要があります。

 (Listに変換する方は、ディクショナリーを使わなかったのでデーターベースに書いてある通りに変換されます。

 ただ、Application.CountA を使っているので数式で空白なんかがあるとちょっとまずいかもしれません。

 その時は、値にするとか、、ちょっと工夫してみてください。)

 問題は、表示シートの方です。こちらは、何度読んでもさっぱりわかりません。

 でも、今までの話の流れからすると、このデーターベースのシートをいずれは List に変換する必要があると思うのです。

 Listに変換さえすれば、

 >それとは別に 
 >・機器毎の年度別使用回数 
 >・機器毎、使用場所毎の年度別使用回数 
 >・データベース1と同じ表示の年度別表示 
 >の3つが欲しいそうです。 

 この辺のことは、別の方法でそう難しくなく出来るでしょう。

 並び替えるもよし、フィルターを使うもよし、、、私は、、あまり詳しくありませんが、、ピボット?テーブル???もよし、、、

 そういえば、、昔、、何とか姫さんと激闘しましたねぇ(^^;すみません。話がそれました。

 それと他のマクロ?システム?との兼ね合いもあるでしょうし、一旦は、Listにして、データーはデーターとして保存して

 この表みたいなデーターベースは量を減らして区切りのいいところからまた始めれられればいいでしょう。

 で、このデーターベースのシートをListに置き換えるコードを書いてみたのですが、、これが、、私史上最悪の激遅です。( ̄▽ ̄;)

 100002行のくらいのデーターですと、軽く2〜3時間は掛かります。

 まぁ、そんなに頻繁にすることでもないでしょうから、帰宅前にポッチっと押して帰ってください。

 ただいくつか問題があります。データーが多くても止まることはないでしょうが、、、900単位で保存する様にしています。

 私のExcelは2007なので、最終行が、1048576ですが、このListに変換するコードは、、データーベースが結構、横に延びているので、

 データーが一杯に詰まった状態だとクラッシュする可能性も無くはないなと思って一応、逃げる様なコードも入れてます。

 が、そこはさすがに未検証です。

 ちなみに、10002行のデータで、1321.579秒、1282.586秒、、

 5061行のデータだと、602.480秒、、、88685行まで展開されます。

 で、私がどうしてもこのトピに解決して欲しい理由、、、とは、、、ちょっとふざけた名前ですけど、

 >Sub お題作成最終版しっかり頼むぜSoulMan今度こそ()

 があるので、、何かの時はこのトピのリンクを貼ってこれを使ってアップしてくださいと使いまわそうと思っているので

 こんな終わり方じゃ情けないかなと、、、、まぁ、、不純な動機ですけど、、、、(笑)

 と言うことでもう寝ます。

 おさすみなさいzzzzzzzzzzzzzzzzzzzzzzz

 Option Explicit
Sub てすと()
Dim MyDic As Object
Dim MyAry() As Variant
Dim x As Variant
Dim MyTblA As Range
Dim MyTblB As Range
Dim MyDate As Long
Dim MyDateA As Date
Dim MyDateB As Date
Dim r As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim 最大値 As Long
Dim MyTimer As Single
MyTimer = Timer
MyDate = Sheets("表示シート").Range("C3").Value
MyDateA = DateSerial(MyDate, 4, 1)
MyDateB = DateSerial(MyDate + 1, 3, 31)
Set MyDic = CreateObject("Scripting.Dictionary")
With Sheets("データベース1")
    Set MyTblA = .Range("F4", .Range("F" & .Rows.Count).End(xlUp))
End With
For Each r In MyTblA
    If r.MergeCells Then
        If r.Address = r.MergeArea.Item(1).Address Then
            MyDic(r.Value) = r.Offset(, 2).Resize(9, r.CurrentRegion.Columns.Count - 7).Value
        End If
    End If
Next
With Sheets("表示シート2")
    Set MyTblB = .Range("A4", .Range("A" & .Rows.Count).End(xlUp))
    k = 1
    ReDim MyAry(1 To MyTblB.Rows.Count + 8, 1 To k)
End With
For Each r In MyTblB
    If r.MergeCells Then
        If r.Address = r.MergeArea.Item(1).Address Then
            x = MyDic(r.Value)
            For j = LBound(x, 2) To UBound(x, 2)
                If (x(3, j) >= MyDateA) * (x(3, j) <= MyDateB) Then
                    If 最大値 < k Then 最大値 = k
                    ReDim Preserve MyAry(1 To MyTblB.Rows.Count + 8, 1 To 最大値)
                    For i = LBound(x, 1) To UBound(x, 1)
                        MyAry(i + n, k) = x(i, j)
                    Next
                    k = k + 1
                End If
            Next
            n = n + 9
            k = 1
        End If
    End If
Next
With Sheets("表示シート2")
    .Range("B4", .Range("B" & .Rows.Count).End(xlUp)).Offset(, 1). _
        Resize(.Range("A3").CurrentRegion.Rows.Count - 3, .Range("A3").CurrentRegion.Columns.Count - 2).ClearContents
    .Range("C4").Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
    .Range("A3").CurrentRegion.EntireColumn.AutoFit
End With
Set MyDic = Nothing
Set MyTblA = Nothing
Set MyTblB = Nothing
Erase MyAry, x
MyTimer = Timer - MyTimer
MsgBox "処理が完了しました。" & vbCrLf & Format(MyTimer, "###0.000" & "秒")
End Sub

 Option Explicit
Sub データベース1をListに変換()
Dim ws As Worksheet
Dim 見出し As Variant
Dim MyA As Variant
Dim MyAry() As Variant
Dim 機器番号 As Variant
Dim MaxRow As Long
Dim i As Long
Dim ii As Long
Dim j As Long
Dim k As Long
Dim kk As Long
Dim n As Long
Dim MyFlg As Boolean
Dim MyFlgA As Boolean
Dim MyFlgB As Boolean
Dim MyTimer As Single
MyTimer = Timer
For Each ws In Worksheets
    If ws.Name = "データベース1List" Then MyFlg = True
Next
If MyFlg = False Then
    Sheets.Add , Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "データベース1List"
End If
Sheets("データベース1List").Cells.Clear
With Sheets("データベース1")
    見出し = .Range("G4:G12").Value
    k = 1
    ReDim MyAry(1 To UBound(見出し, 1) + 1, 1 To k)
    MyAry(1, 1) = .Range("F3").Value
    For i = 1 To UBound(見出し, 1)
        MyAry(i + 1, 1) = 見出し(i, 1)
    Next
    Sheets("データベース1List").Range("A1").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
    MaxRow = .Range("G" & .Rows.Count).End(xlUp).Row
    k = 1
    ReDim MyAry(1 To UBound(見出し, 1) + 1, 1 To k)
    For i = 4 To MaxRow Step 9
        With .Range("G4").Offset(i - 4)
            MyA = .Offset(, 1).Resize(9, .CurrentRegion.Columns.Count - 7).Value
        End With
        For j = LBound(MyA, 2) To UBound(MyA, 2)
            If Application.CountA(Application.Index(MyA, 0, j)) > 0 Then
                kk = kk + 1
                If kk > Rows.Count - 13 Then MyFlgA = True: Exit For
'                If kk > 100 Then MyFlgA = True: Exit For
                ReDim Preserve MyAry(1 To UBound(見出し, 1) + 1, 1 To k)
                MyAry(1, k) = .Range("G4").Offset(i - 4, -1).Value
                For ii = LBound(MyA, 1) To UBound(MyA, 1)
                    MyAry(ii + 1, k) = MyA(ii, j)
                Next
                k = k + 1
            End If
        Next
        If (i - 4) Mod 900 = 0 Then
            If MyFlgB Then
                With Sheets("データベース1List")
                    .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
                End With
                ThisWorkbook.Save
                k = 1
                ReDim MyAry(1 To UBound(見出し, 1) + 1, 1 To k)
            End If
            MyFlgB = True
        End If
        If MyFlgA Then ThisWorkbook.Save: Exit For
    Next
    機器番号 = .Range("F" & i).Value
End With
With Sheets("データベース1List")
    .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
    .Range("A1").CurrentRegion.EntireColumn.AutoFit
    .Activate
    With ActiveWindow
        .ScrollColumn = 1
        .ScrollRow = 1
        .FreezePanes = True
    End With
End With
Erase MyA, MyAry, 見出し
ThisWorkbook.Save
MyTimer = Timer - MyTimer
If MyFlgA Then
    MsgBox "データベース1の " & i & " 行目のレコードで処理能力を超えました。" _
        & vbCrLf & i & " 行以下を再度セットして実行してください。" & _
            vbCrLf & "データベース1List の データーには" & vbCrLf & _
                "機器番号 " & 機器番号 & " のデータが重複する可能性があります。" _
                    & vbCrLf & Format(MyTimer, "###0.000" & "秒")
Else
    MsgBox "処理が完了しました。" & vbCrLf & Format(MyTimer, "###0.000" & "秒")
End If
End Sub
(SoulMan) 2019/01/21(月) 01:12

 こんにちは ^^
な〜るほど。。。。。そぉですよね。
トピ主様も悪気は無いのでしょうが、
場所が全件○○では。検索も区分けも出来ないですね。

 で、とりあえず
私もリストコンバーターみたいなの作ってみました。
アドバンスドフイルター用なので西暦年、4桁だけ後ろに追加
。。。 ( ̄▽ ̄);(私では使いこなせないかも?)
年寄りの力技にて。。。(笑)流して下さりませ。 m(_ _)m

Sub Brock_Convert_to_Table()

    '変数定義
    Dim sConvert As Worksheet
    Dim sDB As Worksheet
    Dim ws As Worksheet
    Dim SheetFlg
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim r As Range
    Dim rr As Range
    Dim DicDB As Object
    Dim D As Variant
    Dim 機器番号 As Long
    Dim 使用機場名 As String
    Dim 持出者名 As String
    Dim 使用開始日
    Dim 返却予定
    Dim 返却日
    Dim 返却者名 As String
    Dim 校正送付日
    Dim 修理依頼日
    Dim 備考 As String
    Dim 検索年
    Dim t
    t = Timer
    'シート設定
    For Each ws In Worksheets
        If ws.Name = "変換Brock_Convert_to_Table" Then SheetFlg = True
    Next
    If SheetFlg = False Then
        Worksheets.Add before:=Worksheets(1)
        ActiveSheet.Name = "変換Brock_Convert_to_Table"
    End If
    Set sConvert = Worksheets("変換Brock_Convert_to_Table")
    'Set sDB = Worksheets("データベース1")
    'ダミー約 50,000 行(280件?),下記シート名にて作成
    Set sDB = Worksheets("データベース2")
    Set rr = sDB.UsedRange
    Set rr = Intersect(sDB.UsedRange, sDB.Range(sDB.Rows(4), sDB.Rows(sDB.UsedRange.Rows.Count)))
    Set rr = Intersect(rr, sDB.Range(sDB.Columns(6), sDB.Columns(rr.Columns.Count)))
    sConvert.Cells.Clear
    sConvert.Range("A1").Resize(1, 11) = Array("機器番号", "使用機場名", "持出者名", _
                                               "使用開始日", "返却予定", "返却日", "返却者名", _
                                               "校正送付日", "修理依頼日", "備考", "検索年")
    Set DicDB = CreateObject("Scripting.Dictionary")
    With sConvert
        For i = 1 To rr.Rows.Count Step 9
            If Data_Check(rr, i) Then
                For j = 3 To rr.Columns.Count
                    If WorksheetFunction.Count(sDB.Range(rr(i, j), rr(i, j).Offset(8))) > 0 Then
                        機器番号 = rr(i, 1).Value
                        使用機場名 = rr(i, j)
                        持出者名 = rr(i, j).Offset(1)
                        使用開始日 = rr(i, j).Offset(2)
                        返却予定 = rr(i, j).Offset(3)
                        返却日 = rr(i, j).Offset(4)
                        返却者名 = rr(i, j).Offset(5)
                        校正送付日 = rr(i, j).Offset(6)
                        修理依頼日 = rr(i, j).Offset(7)
                        備考 = rr(i, j).Offset(8)
                        検索年 = Left(rr(i, j).Offset(2), 4)
                        DicDB(n) = Array(機器番号, 使用機場名, 持出者名, _
                                         使用開始日, 返却予定, 返却日, 返却者名, _
                                         校正送付日, 修理依頼日, 備考, 検索年)
                        n = n + 1
                    End If
                    DoEvents
                    Application.StatusBar = Space(10) & Format(n, "0,0")
                Next
            Else
                Exit For
            End If
            DoEvents
        Next
        n = 2
        For Each D In DicDB.Items
            .Cells(n, 1).Resize(1, UBound(D) + 1) = D
            n = n + 1
            Application.StatusBar = Space(10) & Format(n, "0,0")
            DoEvents
        Next
        .UsedRange.EntireColumn.AutoFit
    End With
    MsgBox Format(Timer - t, "###0.000" & "秒")
    Application.StatusBar = ""
End Sub
Private Function Data_Check(ByVal rr As Range, ByVal i As String) As Boolean
    If rr(i, 2) = "使用機場名" And rr(i, 2).Offset(8) = "備考" Then
        Data_Check = True
    Else
        Data_Check = False
    End If
End Function
(隠居じーさん) 2019/01/21(月) 11:07

 追伸
端から端まで、びっしり、データが詰まっていたら。。。(G〜IT列まで) ( ̄▽ ̄);
2〜3時間では済まないかも。。。。
ですね。

 反省しています。
勉強のためにSoulmanさんのコードを参考に(要所、要所で保存?等)
修正してみます。
m(_ _)m
(隠居じーさん) 2019/01/21(月) 11:47

 よくは見てませんが、
いやぁぁ、もう神さま仏さま隠居じーさん 様ですよぉ、
よぉ〜見てへんのんかえぇ(笑)
すみません
ありがとうございます😊
(SoulMan) 2019/01/21(月) 12:10

SoulManさん

ご意見ありがとうございます。申し訳ありません。
こちらも仕事の作業で行っている案件で
自分がどうこうしたいということではなく

こうしたいといわれているので
こういったようにしたいらしいけど、関数では色々クッションを入れればどうにかできるけど重たすぎて実用性に欠けるので
マクロを使って実用性があるものにできないか。

と、相談させていただきました。
皆さんのご意見で、決まった型を崩しての意見をいただきましたが、

最終的に、エクセルを詳しくない上司からの希望である
《やり方はあやふやな決まった形》にする必要があります。

自分は、簡単な転記や色付け並べかえのマクロは調べながらくめても
マクロに詳しくなくどこまでどんなことができるのか
また、この作業をする為にどんなコードが必要なのかまったくわかりません。

勉強とかでもそうですけど、
何がわからないかわからない。みたいな状態なのです。

> 例えば、、例をあげて この表を→こうしたい ただそれだけなんですよ。
とおっしゃられていますが。

データベースを使って
・機器毎の年度別使用回数
・機器毎、使用場所毎の年度別使用回数
・データベース1と同じ表示の年度別表示

を作りたい。がそれです。

そして、それを構成するためにはデータベース1の中のデータを参照したいので
そこからデータを参照する様にしたいとお伝えいたしました。

言い方は第3者視点になってしまっているかもしれませんが。
自分が抱えているデータの状態を知識のある方に
なるべく正しく認識していただき、ご意見いただけるように
説明をできればと。

ご連絡に必要な新規ブックの情報は
元にしたいデータと作りたい形を作ったデータにしました。

ただし、データベース1を作る為のデータに関しては、
昔在社した方の作ったマクロがもとになっている為、
物件名等を引っ張ってくるリストは更に違うシートになっています。
そういった一覧のリストも必要なのかわからないが
あった方がいいのであれば新規ブックに追加しますと言ったつもりでした。
※データベース1に転記された物件名だけ使えばできるといわれれば必要はないと思いましたので。

この表をこの形にしたい。
それを伝えるたびに、話が見えない。
そういわれたのでどうやって説明したら伝わるのか。
試行錯誤してお伝えしていますが、結果そんな説明はいらないと言われてしまいます。

経験がない質問者側からしてみれば、回答者様が当たり前でしょ?
と思っている事でも、
この情報だけで大丈夫なのだろうか。
この情報もあった方がいいのだろうか。
こうなるまではどうしているというのは伝えた方がいいのだろうか。
何を伝えたら理解してもらえるのだろうかと不安になりながら質問しています。
確かに、丸投げ状態にしてしまっているなと思う申し訳ない気持ちもあります

しかし、自分本位な意見になりますが
自分一人でできている事ならそもそも、質問することもありません。
考えて調べて何も進展しなくて、上司からの無茶ブリもどんどん注文が増えていき
どうしようもなくてもやらなければいけない状況になってきたので、
詳しい人に聞いてみたら、いいのではないだろうか。
と、相談させていただいた次第です。

話が、かみ合っていない様で申し訳ありません。

(はるはる) 2019/01/21(月) 14:06


隠居じーさんさん

>場所が全件○○では。検索も区分けも出来ないですね。

すみません。
○○の部分は担当者名と元データのメモシートにある場所の一覧から記載はされていたのですが。
シート全体を変更しなければならないと思い量が多かった為、一時的に〇〇に変えてしまいました。

多少時間がかかってもすべて置き換えたものに変更してから質問するべきでした。
ごめんなさい。
(はるはる) 2019/01/21(月) 14:14


 SoulManさんも
お忙しそうですが、きっと、アドバイス、下さると思いますよ。
頑張ってくださいね。 ^^

 お師匠様。。。
下記にコード変更したら。。。2シートに分けて68万と69万件、計 137万件 ^^;
www。。。所要時間 3641.523秒
一時間ちょいでした。
保存すると、一瞬かたまりそぉなくらい、重くなっています @@;
これで計算式なぞたっぷり入っていると。。。。( ̄▽ ̄);
トピ主様、たいへんそうですね〜〜〜
もし、仮にリスト化で対応されるのでしたら、別BOOKにする。ってのも
ありかもですね。
老人の独り言でした。どうぞ、お聞き流しを
m(_ _)m
最後の書き出し部分、のみ変更
 n = 2
    For Each D In DicDB.Items
        If n >= 700000 Then
            sConvert.UsedRange.EntireColumn.AutoFit
            Worksheets.Add Worksheets(1)
            Set sConvert = ActiveSheet
            n = 1
        End If
        sConvert.Cells(n, 1).Resize(1, UBound(D) + 1) = D
        n = n + 1
        Application.StatusBar = Space(10) & Format(n, "0,0")
        DoEvents
    Next
    sConvert.UsedRange.EntireColumn.AutoFit
    MsgBox Format(Timer - t, "###0.000" & "秒")
    Application.StatusBar = ""
End Sub
(隠居じーさん) 2019/01/21(月) 16:23

 こんばんは!

 >データベースを使って 
 >・機器毎の年度別使用回数 
 >・機器毎、使用場所毎の年度別使用回数 
 >・データベース1と同じ表示の年度別表示 
 >を作りたい。がそれです。 

 お題は確かにたまわりました。第一印象、、、レイアウトにこだわらないのであればそんなに難しくない(おいおい、SoulManそんな大口たたいて大丈夫かよぉ、ちょっと見栄をはりました。だから、端っこに書いてます。( ̄▽ ̄;))

 お題のうち、
  >・データベース1と同じ表示の年度別表示 
 はもう出来てますよね?

 後は、、、機器ごと??これは機器番号ごと???

 機器番号って固有ですか?重複してない?

 他の場所とか担当者は多分重複しててそれで以前機器番号をくっつけてユニークなKeyにされていたのかな????

 年度別?これは、使用開始日だけを見ていればいいのかな?

 後は、使用回数???、、これだね??何をもって 1回とするかによっては難易度が上がりそうな気もするけど、、、そうでもないか???

 使用場所毎の?? これは、使用機場名をみればいいみたいだし、、、年度別? これは、誰かから与えられる?それとも、データベースにあるもの全部?

 データベースにあるもの全部となると、、、一回、、なめないといけないよう気がするけど、、、どうなんだろう???

 使用回数????、、、これも、何をもって1回とするかだね?

 まぁ、、、平日はどうせ無理だし、、時間が出来るまで待っていただけるなら、、、何とかなるんじゃないですかぁ???(かなり見栄はってます( ̄▽ ̄;))

 回答者って実はタイムリーで大変なのよ。時間とF8さえあれば、、、何だって(←言い過ぎ)駄目なら書き直せばいいんだから(笑)

 隠居じーさん さん、、リストの案いいと思いますけどねぇ????まぁ、、、、色々とあるんでしょう。。。。

 私の場合、、コードを書くこと自体はそんなに時間はかからない。。。ただ、、、イメージが固まるまでが長い。。。。

 入り方を間違えると簡単なことが面倒になったりするから、、お風呂に入ってる時も考えてる。。そんで、ぱっとひらめいたときに一気に書く。。。

 変な話、、今日書くのと三日後に書くとのとじゃ違う時もある。一年前に書いたコード何てのはとても自分が書いたコードとは思えないコードもある。。。

 だから、要所々にコメントを入れておく。。。。で、後で見て「こりゃ、違うだろう」と書き直すと大概動かない(笑)

 書いてる時は、前後のこととか色々な場面を想像しながら書いてるからつながっているんだけど、、、急に横から入ると解読しきれていないから失敗する。

 えっ???何の話だ?こりゃ???まぁ、、気長に行きましょう。。。トピもこれだけ長くなるとよっぽどコアな人でないと見てませんから(笑)

 私だったらとっくに「無理!!!」ってスルーしてます。。。だって、前後の話が読めないから入りようがないのよね。。。。

 最近、体力がなくてね。。。。根気もないけど、、、、でも、、、帰って来てくれて良かった。良かった。

 では、では、、、、
(SoulMan) 2019/01/21(月) 20:23

 まぁ、データはちょっと端折ってますけど、、、↓こんなデータがあったとして
年度を 2016 と与えられて、、、使用開始日 がその範囲ということなら、、

 機器番号		1	2	3	4	5	6	7	8
6	使用機場名	A1	A2	A3	E1				
	持出者名	     あああ1	ああ9	vv2	sっせ				
	使用開始日		2015/10/2	2016/5/19	2016/6/30				
	返却予定		2016/9/1	2016/7/1	2016/10/31				
	返却日	      2015/10/28	2018/3/29	2016/6/29	2016/8/9				
	返却者名	        ss2	ddd4 	りんご	なし				
	校正送付日	2015/9/25							
	修理依頼日								
	備考	最初							
7	使用機場名	あ1	あ2	あ3	え6	あ1	あ2	え6	え5
	持出者名	    sss	dddr	vv2	sっせ	ff	gfd	bhy	くぁz
	使用開始日	2015/5/8		2016/5/19	2016/6/30	2016/9/26	2016/9/29	2016/11/16	2016/12/9
	返却予定	        2016/3/31		2016/7/1	2016/10/31	2016/9/30	2016/10/14	2016/11/18	2016/12/16
	返却日	        2016/4/11	2016/4/21	2016/6/29	2016/8/9	2016/9/27	2016/10/31	2016/11/17	2016/12/16
	返却者名	     そなた	    まさか	りんご	なし	みかん	もも	りんご	 セニョール
	校正送付日		2016/4/11						
	修理依頼日								
	備考								

 こんな↓なのはよくある話ですけどね。。。レイアウトにこだわらなければ、、、

 機器番号 使用機場名	回数
6	     A3	         1
6	     E1	         1
7	     A3	         1
7	     E1	         1
7	    あ3	         1
7	    え6	         2
7	    あ1	         1
7	    あ2	         1
7	    え5	         1
7	    す3	         1

 Option Explicit
' >・機器毎の年度別使用回数
' >・機器毎、使用場所毎の年度別使用回数
Sub てすと()
Dim MyDicA As Object
Dim MyDicB As Object
Dim ws As Worksheet
Dim MyTblA As Range
Dim r As Range
Dim MyDate As Long
Dim MyDateA As Date
Dim MyDateB As Date
Dim x As Variant
Dim xx As Variant
Dim y As Variant
Dim yy As Variant
Dim z As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim MyFlg As Boolean
Dim MyTimer As Single
MyTimer = Timer
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
MyDate = Sheets("表示シート").Range("C3").Value
MyDateA = DateSerial(MyDate, 4, 1)
MyDateB = DateSerial(MyDate + 1, 3, 31)
Set MyDicA = CreateObject("Scripting.Dictionary")
Set MyDicB = CreateObject("Scripting.Dictionary")
With Sheets("データベース1")
    Set MyTblA = .Range("F4", .Range("F" & .Rows.Count).End(xlUp))
End With
For Each r In MyTblA
    If r.MergeCells Then
        If r.Address = r.MergeArea.Item(1).Address Then
            MyDicA(r.Value) = r.Offset(, 2).Resize(9, r.CurrentRegion.Columns.Count - 7).Value
        End If
    End If
Next
y = MyDicA.Keys
k = 1
ReDim w(1 To 3, 1 To k)
w(1, k) = "機器番号"
w(2, k) = "使用機場名"
w(3, k) = "回数"
For i = LBound(y) To UBound(y)
    x = MyDicA(y(i))
    For j = LBound(x) To UBound(x)
        If x(3, j) <> Empty Then
            If (x(3, j) >= MyDateA) * (x(3, j) <= MyDateB) Then
                MyDicB(x(1, j)) = MyDicB(x(1, j)) + 1
            End If
        End If
    Next
    xx = MyDicB.Keys
    For j = LBound(xx) To UBound(xx)
        k = k + 1
        ReDim Preserve w(1 To 3, 1 To k)
        w(1, k) = y(i)
        w(2, k) = xx(j)
        w(3, k) = MyDicB(xx(j))
    Next
MyDicB.RemoveAll
Next
With Sheets("抽出先")
    .Cells.Clear
    With .Range("A1")
        .Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w)
        .CurrentRegion.EntireColumn.AutoFit
    End With
End With
Set MyDicA = Nothing
Set MyDicB = Nothing
Erase x, xx, y, w
MyTimer = Timer - MyTimer
MsgBox "処理が完了しました。" & vbCrLf & Format(MyTimer, "###0.000" & "秒")
End Sub
すみません。ちょっと間違えました。吐き出す前にカチカチしてどうぉすんだよぉぉ もう、寝ますzzzzzzzzz
一回目のループを抜けた後にMyDicBを初期化しないとひきずるね
(SoulMan) 2019/01/21(月) 22:41

隠居じーさんさん
お疲れ様です。

>もし、仮にリスト化で対応されるのでしたら、別BOOKにする。ってのも
ありかもですね。
そうなんです、なぜこんな面倒な形にしたのか
別ブックにすつ

SoulManさん隠居じーさんさん
お疲れ様です。

>もし、仮にリスト化で対応されるのでしたら、別BOOKにする。ってのも
ありかもですね。
そうなんです、なぜこんな面倒な形にしたのか
別のリストの形に変えれたら一番いいんでしょうが、却下されてしまって、、、
蓄積データとしてバックで使用はできると思うのですが、

あくまで最終的に
表示シートと表示シート2の形に持っていきたいらしいんですよね…

問題と回答が提示されていて
途中式は自分で作れって言われてるんです…

社内サーバーでの管理されていたり不特定多数の人が頻繁に触るので別ブックにすると
いつの間にか破損していたりなくなっていたりしていることが多いので一つにまとめようってなりまして…
(はるはる) 2019/01/22(火) 09:22


 おはようございます。 ^^
いえいえ。。。私へのお気遣いはご無用に、のぞかせていただいて
勉強させていただいております。
早くテスト環境が整えばいいですね。
でわ
(隠居じーさん) 2019/01/22(火) 09:55

SoulManさん
すみません。
夜と休日は別で仕事を入れてしまってるので、
確認できるのが、日中の事務の仕事のときくらいでして…
質問させていただいたからには、ちゃんとしたいとは思っていますので
遅くなっても確認と返信はできるようにしたいと思っています。

>後は、、、機器ごと??これは機器番号ごと???
機器毎に固定になっています。

>他の場所とか担当者は多分重複しててそれで以前機器番号をくっつけてユニークなKeyにされていたのかな????
場所と使用者は重複します。
以前の関数はたぶんそんな感じでセルの位置を呼ぶキーにしてたと思います。

> 年度別?これは、使用開始日だけを見ていればいいのかな?
使用開始日のみで大丈夫です
例えば
使用開始日が2016年度中(2016/4〜2017/3)になっているのが何個あるか。

>使用回数???
こちらも使用開始日をカウントしたいです。
6番の機器の使用開始日が2016年度中(2016/4〜2017/3)が何回あるか。

例:2016と指定した場合

通番 機器番号 2016
1    6    2
2    7    6

表示シートの表に入力なので
A列に通番
B列に機器番号
C列に回数

※↓こんなデータがあったとしてを参照

>使用場所毎の?? 
上記に検索条件が追加された形になるのですが
6番の機器の使用開始日が2016年度中(2016/4〜2017/3)がどこの場所で何回あるか。

	A3	E1	あ1	あ2	あ3	え5	え6
6	1	1
7			1	1	1	1	2

表示シートの表に入力なので
A列に通番
B列に機器番号
はそのまま流用で

E列以降に機場名と回数

※↓こんなデータがあったとしてを参照

(はるはる) 2019/01/22(火) 10:26


お題のうち、
  >・データベース1と同じ表示の年度別表示 
 はもう出来てますよね?

の部分なのですが、すみませんどれが当たるのかよくわからなくなってしまっていまして、

データベース1を使って
表示シート2の表にこう表示したい

という感じのを作ったので確認いただいて、
その部分をもう一度教えていただいてもよろしいでしょうか?

(はるはる) 2019/01/22(火) 10:40


 こんばんは!

 えぇぇ〜〜と、、、これから先もまだ続くんでしょうけど、、一番守って欲しいのは

 レイアウト です。 これが全てですと言っても過言ではありません。

 なので、今回の場合でしたら、、面倒でも二つサンプルコードを走らせて作らないと意味がないんです。

 行が一行、列が一列違っても動きませんし、、動いても正しい答えかどうかは疑問です。

 ここ、凄く大事なのでよろしくお願いします。まぁ、、あまり強く言っても仕方ないので今後は注意してください。

 ほんのひと手間ですからね そこを惜しむと前に進みません。基本です。見えない者同士が想像しながら進めていることですからね。

 それによっては、私が今後示すサンプルコードも怪しくなってきますからね。

 で、表示シート2 の方ですけど、、、A列とB列がすでに入力されている状態で、現状だと

 C4 から表示されることが前提です。

 年度は、表示シート の C3 を見ています。これが大前提です。 

 ここまで話せばいかにレイアウトが大事かわかりますよね。

 で、Sub 表示シート2てすと() わかりやすく名前を変えておきました。

 例によって機器番号が データベースにない時にエラーになったのでそこを少し修正しています。

 それから、

 >6番の機器の使用開始日が2016年度中(2016/4〜2017/3)がどこの場所で何回あるか。

 どうもレイアウトが邪魔で表示しようと思えば出来るんでしょうけど、、表示シートの

 C3の左に機器番号があったり、一つ上に場所があったりでどうも具合が悪いです。

 頂いたサンプルデータのレイアウトが最初と変わっていましたので、、

 3行目に

 通番	機器番号	使用回数	カウント	フラグ

 G4から
使用機場名
持出者名
使用開始日
返却予定
返却日
返却者名
校正送付日
修理依頼日
備考

 というレイアウトに変えて、、二つじゃ寂しいのでコピーして四つにして、機器番号を 8 9 と増やしました。

 取り敢えず、、出力先を、、抽出シート のA1からにしています。まぁ、そこからLinkと考えてみて下さい。

 どうも、通番とか機器番号とかの出方が分からないので、、、ちょっと手間です。

 一応、頂いたデータだと↓こんな感じになりました。あってますか?

 これは、2016 の時です。
	A2	E2	A3	E3	A4	E4	A5	E5	A6	E6	A7	E7	A8
6													
7	1	1	1	1	1	1	1	1	1	1	1	1	1
8													
9	1	1	1	1	1	1	1	1	1	1	1	1	1

 2015 だと
	E1	A1
6	1	
7		1
8	1	
9		1

 2017だと
	A9	E9	A10	E10	A11	E11	A12
6							
7	1	1	1	1	1	1	1
8							
9	1	1	1	1	1	1	1

 こんな感じです。

 機器番号と場所を固定にしてそこから持って来るようにした方がいいのかもしれませんね。そこは、考え方だし、、、まぁ、、色々あるんでしょう。。。

 ちなみに、100002行のサンプルデータで 406.750秒 でした。

 では、では、もう夜中だし、、、寝ます。

 おやすみなさいzzzzzzzzzzzzzzzzzzzzzzzzz

 Option Explicit
Sub 表示シート2てすと()
Dim MyDic As Object
Dim MyAry() As Variant
Dim x As Variant
Dim MyTblA As Range
Dim MyTblB As Range
Dim MyDate As Long
Dim MyDateA As Date
Dim MyDateB As Date
Dim r As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim 最大値 As Long
Dim MyTimer As Single
MyTimer = Timer
MyDate = Sheets("表示シート").Range("C3").Value
MyDateA = DateSerial(MyDate, 4, 1)
MyDateB = DateSerial(MyDate + 1, 3, 31)
Set MyDic = CreateObject("Scripting.Dictionary")
With Sheets("データベース1")
    Set MyTblA = .Range("F4", .Range("F" & .Rows.Count).End(xlUp))
End With
For Each r In MyTblA
    If r.MergeCells Then
        If r.Address = r.MergeArea.Item(1).Address Then
            MyDic(r.Value) = r.Offset(, 2).Resize(9, r.CurrentRegion.Columns.Count - 7).Value
        End If
    End If
Next
With Sheets("表示シート2")
    Set MyTblB = .Range("A4", .Range("A" & .Rows.Count).End(xlUp))
    k = 1
    ReDim MyAry(1 To MyTblB.Rows.Count + 8, 1 To k)
End With
For Each r In MyTblB
    If r.MergeCells Then
        If r.Address = r.MergeArea.Item(1).Address Then
            x = MyDic(r.Value)
            If IsArray(x) Then
                For j = LBound(x, 2) To UBound(x, 2)
                    If (x(3, j) >= MyDateA) * (x(3, j) <= MyDateB) Then
                        If 最大値 < k Then 最大値 = k
                        ReDim Preserve MyAry(1 To MyTblB.Rows.Count + 8, 1 To 最大値)
                        For i = LBound(x, 1) To UBound(x, 1)
                            MyAry(i + n, k) = x(i, j)
                        Next
                        k = k + 1
                    End If
                Next
                n = n + 9
                k = 1
            End If
        End If
    End If
Next
With Sheets("表示シート2")
    .Range("B4", .Range("B" & .Rows.Count).End(xlUp)).Offset(, 1). _
        Resize(.Range("A3").CurrentRegion.Rows.Count - 3, .Range("A3").CurrentRegion.Columns.Count - 2).ClearContents
    .Range("C4").Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
    .Range("A3").CurrentRegion.EntireColumn.AutoFit
End With
Set MyDic = Nothing
Set MyTblA = Nothing
Set MyTblB = Nothing
If IsArray(x) Then Erase x
Erase MyAry
MyTimer = Timer - MyTimer
MsgBox "処理が完了しました。" & vbCrLf & Format(MyTimer, "###0.000" & "秒")
End Sub

  Option Explicit
' >・機器毎の年度別使用回数
' >・機器毎、使用場所毎の年度別使用回数
Sub てすと()
Dim MyDicA As Object
Dim MyDicB As Object
Dim MyDicC As Object
Dim MyDicD As Object
Dim MyAry() As Variant
Dim ws As Worksheet
Dim MyDate As Long
Dim MyDateA As Date
Dim MyDateB As Date
Dim x As Variant
Dim xx As Variant
Dim y As Variant
Dim yy As Variant
Dim MaxRow As Long
Dim i As Long
Dim j As Long
Dim ii As Long
Dim jj As Long
Dim k As Long
Dim MyFlg As Boolean
Dim MyTimer As Single
MyTimer = Timer
MyDate = Sheets("表示シート").Range("C3").Value
MyDateA = DateSerial(MyDate, 4, 1)
MyDateB = DateSerial(MyDate + 1, 3, 31)
Set MyDicA = CreateObject("Scripting.Dictionary")
Set MyDicB = CreateObject("Scripting.Dictionary")
Set MyDicC = CreateObject("Scripting.Dictionary")
Set MyDicD = CreateObject("Scripting.Dictionary")
For Each ws In Worksheets
    If ws.Name = "抽出先" Then MyFlg = True: Exit For
Next
If MyFlg = False Then
    Sheets.Add , Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "抽出先"
End If
With Sheets("データベース1")
    MaxRow = .Range("G" & .Rows.Count).End(xlUp).Row
    For i = 4 To MaxRow Step 9
        With .Range("G4")
            MyDicA(.Offset(i - 4, -1).Value) = .Offset(i - 4, 1).Resize(9, .CurrentRegion.Columns.Count - 7).Value
        End With
    Next
End With
y = MyDicA.Keys
For i = LBound(y) To UBound(y)
    x = MyDicA(y(i))
    For j = LBound(x, 2) To UBound(x, 2)
        If x(3, j) <> Empty Then
            If (x(3, j) >= MyDateA) * (x(3, j) <= MyDateB) Then
                MyDicB(x(1, j)) = MyDicB(x(1, j)) + 1
                MyDicC(x(1, j)) = Empty
            End If
        End If
    Next
    xx = MyDicB.Keys
    For j = LBound(xx) To UBound(xx)
        MyDicD(y(i) & xx(j)) = MyDicB(xx(j))
    Next
    MyDicB.RemoveAll
Next
yy = MyDicC.Keys
ReDim MyAry(LBound(y) + 1 To UBound(y) + 2, LBound(yy) + 1 To UBound(yy) + 2)
For i = LBound(MyAry, 1) + 1 To UBound(MyAry, 1)
    MyAry(i, 1) = y(i - 2)
Next
For j = LBound(MyAry, 2) + 1 To UBound(MyAry, 2)
    MyAry(1, j) = yy(j - 2)
Next
For i = LBound(MyAry, 1) + 1 To UBound(MyAry, 1)
    For j = LBound(MyAry, 2) + 1 To UBound(MyAry, 2)
        MyAry(i, j) = MyDicD(y(i - 2) & yy(j - 2))
    Next
Next
With Sheets("抽出先")
    .Cells.Clear
    With .Range("A1")
        .Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
        .CurrentRegion.EntireColumn.AutoFit
    End With
End With
Set MyDicA = Nothing
Set MyDicB = Nothing
Set MyDicC = Nothing
Set MyDicD = Nothing
Erase x, xx, y, yy, MyAry
MyTimer = Timer - MyTimer
MsgBox "処理が完了しました。" & vbCrLf & Format(MyTimer, "###0.000" & "秒")
End Sub
※MyAryの消し忘れwww
(SoulMan) 2019/01/23(水) 01:05

 おはようございます。
 
 今日は、抜糸なので機器番号と使用機場名を表示シートから与えられるヴァージョンも書いてみました。

 でも、この場合は、、機器番号とか使用機場名に抜けがあると表示されません。

 まぁ、抽出するという意味では、、必要なものしか記入しないのでしょうから、、、どうなんでしょう???

 考え方ですね。

 都合のいい方を使って下さい。

 機器番号	2015	機場名→	A1	A2	A3	E1	E2	A9	E9	A10	E10	A11	E11	A12
6	1	回数↓				1								
7	0													
8	0					1								
9	0													

 機器番号	2016	機場名→	A1	A2	A3	E1	E2	A9	E9	A10	E10	A11	E11	A12
6	1	回数↓												
7	0			        1	1		1							
8	0													
9	0			        1	1		1							

 機器番号	2017	機場名→	A1	A2	A3	E1	E2	A9	E9	A10	E10	A11	E11	A12
6	1	回数↓												
7	0							        1	1	1	1	1	1	1
8	0													
9	0							        1	1	1	1	1	1	1

 表示の図がずれていたらごめんちゃいm(__)m

 では、では、
 Option Explicit
' >・機器毎の年度別使用回数
' >・機器毎、使用場所毎の年度別使用回数
Sub 機器番号と使用場所がSheetから与えられるなら()
Dim MyDicA As Object
Dim MyDicB As Object
Dim MyAry() As Variant
Dim 機器番号 As Variant
Dim 使用機場名 As Variant
Dim ws As Worksheet
Dim MyDate As Long
Dim MyDateA As Date
Dim MyDateB As Date
Dim x As Variant
Dim y As Variant
Dim MaxRow As Long
Dim i As Long
Dim j As Long
Dim ii As Long
Dim jj As Long
Dim k As Long
Dim MyTimer As Single
MyTimer = Timer
MyDate = Sheets("表示シート").Range("C3").Value
MyDateA = DateSerial(MyDate, 4, 1)
MyDateB = DateSerial(MyDate + 1, 3, 31)
Set MyDicA = CreateObject("Scripting.Dictionary")
Set MyDicB = CreateObject("Scripting.Dictionary")
With Sheets("表示シート")
    With .Range("C3")
        使用機場名 = .Offset(, 2).Resize(, .CurrentRegion.Columns.Count - 4).Value
    End With
    With .Range("B4")
        機器番号 = .Resize(.CurrentRegion.Rows.Count - 2).Value
    End With
End With
ReDim MyAry(LBound(機器番号, 1) To UBound(機器番号, 1), LBound(使用機場名, 2) To UBound(使用機場名, 2))
With Sheets("データベース1")
    MaxRow = .Range("G" & .Rows.Count).End(xlUp).Row
    For i = 4 To MaxRow Step 9
        With .Range("G4")
            MyDicA(.Offset(i - 4, -1).Value) = .Offset(i - 4, 1).Resize(9, .CurrentRegion.Columns.Count - 7).Value
        End With
    Next
End With
y = MyDicA.Keys
For i = LBound(y) To UBound(y)
    x = MyDicA(y(i))
    For j = LBound(x, 2) To UBound(x, 2)
        If x(3, j) <> Empty Then
            If (x(3, j) >= MyDateA) * (x(3, j) <= MyDateB) Then
                MyDicB(y(i) & x(1, j)) = MyDicB(y(i) & x(1, j)) + 1
            End If
        End If
    Next
Next
For i = LBound(MyAry, 1) To UBound(MyAry, 1)
    For j = LBound(MyAry, 2) + 1 To UBound(MyAry, 2)
        MyAry(i, j) = MyDicB(機器番号(i, 1) & 使用機場名(1, j))
    Next
Next
With Sheets("表示シート")
    With .Range("E4")
        .Resize(UBound(MyAry, 1), UBound(MyAry, 2)).ClearContents
        .Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
        .CurrentRegion.EntireColumn.AutoFit
    End With
End With
Set MyDicA = Nothing
Set MyDicB = Nothing
Erase x, y, MyAry, 機器番号, 使用機場名
MyTimer = Timer - MyTimer
MsgBox "処理が完了しました。" & vbCrLf & Format(MyTimer, "###0.000" & "秒")
End Sub

 散歩しながらよくよく考えてたら 機器番号と使用場所がSheetから与えられるなら 
使用場所 が重複していても 機器番号 と組み合わせることでそれ自体がユニークKeyなので
あれもこれもいりませんね。(^^;

 難易度が、ぐっぐっぐぅぅぅぅと下がっちゃいましたね。これは、ひょっとすると解決かもしれませんね。

ぶっ飛ぶ準備はできたかぃぃ?????(AreYouRedayOk???)I am Ok! v(=∩_∩=)v

 やっぱコードを書くのは朝がいい、、、夜は頭回ってへんわ_| ̄|○
(SoulMan) 2019/01/23(水) 07:58

おはようございます ^^
>>今日は、抜糸なので
どこぞお怪我でも? お大事に m(_ _)m

140万件、ループ回して遊んでいます。
どぉすりゃ早くなるんだろ〜〜〜みたいな。
お題も完成まじかみたいですね。
よかったです。
でわでわ
また
あまり、関係ない書込みで はるはる さん 
すみません
m(_ _)m

(隠居じーさん) 2019/01/23(水) 09:59


 おはようございます。

 今日は、また、痛そうです。

 よい一日であります様に!!!
(SoulMan) 2019/01/23(水) 10:04

 でも、このお題の一番の解決策は List案 ですよね?
(SoulMan) 2019/01/23(水) 10:21

 いえいえ ^^
トピ主様はとくに方法はこだわらないのでは無いでしょうか
ディクショナリ、と配列の使い方等、
凄く勉強させていただいております。
List案。。。比較的簡単に(隠居じーさんでも)組めなくはないのかな
と思うだけです。
ただ時間との格闘が。。。残されております ← これ隠居じーさんだけ? ^^;
トピ主様のご質問には関係なく。
年寄りが独り遊びしておるだけでしてお聞き捨てくださりませ。
エクセルいじってると楽しいです。 (#^.^#)
m(_ _)m
(隠居じーさん) 2019/01/23(水) 11:08

SoulManさん

お疲れ様です。
抜糸ですか…
あれ何回やっても切る時と抜くときの感覚が気持ち悪くてなれません、、、、
最近はホッチキスのようなものでやるとこがありますけどあれも抜くとき気持ち悪いんだろうか…

サンプルに関してすみません
以降気を付けます。

Sub 表示シート2てすと()ですがほぼ理想通りで感動いたしました!

こちらなのですが、ふと校正に出したとこだけ見たいといわれるような気がしてきまして、
校正送付日で同様の事ができないかなと思ったのですが
参照場所を使用開始日から校正送付日に変更すれば同様に動くものなのでしょうか?
※どのコードでどう動いているというのはまだ理解できていないです。

表示シートの方ですが
・機器毎、使用場所毎の年度別使用回数
抽出先シートへの転記との事でしたがこちらもほぼ理想通りでした!
抽出先シートへの物を表示シートへ変更と転記場所の指定をすれば表示シートに転記できるかな?
と思ってやってみましたが、、、
やっぱりそんな単純やないですよね←
表示シートのE4から張り付いたけど左のリストやらもろもろ消えてしまって焦りました←

機器毎の年度別使用回数に関しては
機器毎、使用場所毎の年度別使用回数をカウント等の関数で持ってい胃のだろうか、、とか

最後のコードなのですが、
下記でエラーが出るのは、機器番号とか使用機場名に抜けがあると言うことなのでしょうか?

ReDim MyAry(LBound(機器番号, 1) To UBound(機器番号, 1), LBound(使用機場名, 2) To UBound(使用機場名, 2))

質問ばかりですみません。
そして、バタバタしていて落ち着いて読みこめていないのでまた変な事言っていたらすみません…
(はるはる) 2019/01/23(水) 13:44


隠居じーさんさん

いえ、私ではわからない部分などお伝えいただけてとても助かっております!
ありがとうございます!

SoulManさん
すみません、午前中に拝見させていただいて返信打つのに今までかかっていたら更新されてました…
これから、外出があるので確認できるのは明日になってしまうかもしてません…

(はるはる) 2019/01/23(水) 13:48


 >参照場所を使用開始日から校正送付日に変更すれば同様に動くものなのでしょうか? 

 これは、今は、開始日だから、

 使用機場名    1
 持出者名      2
 使用開始日    3←ここ
 返却予定      4
 返却日        5
 返却者名      6
 校正送付日    7
 修理依頼日    8
 備考          9

       ↓ここが 3 です。
 >If (x(3, j) >= MyDateA) * (x(3, j) <= MyDateB) Then

 4 にすれば 返却日 7 にすれば校正日 8 にすれば 修理日 となります。

 以上、このトピは今後、私によって使いまわされることになるでしょうから、、、よろしくお願いします。(何をぉぉ???(笑))

 後は、ここからがお勉強なのでお勉強してください。

 では、では、また、、、
(SoulMan) 2019/01/23(水) 16:58

SoulManさん

ご連絡が遅くなり申し訳ありません。

・機器毎、使用場所毎の年度別使用回数

表示シートへ表示させることができました!

表示シート2の表示と参照場所を変えての表示も無事にすることができました!

・機器毎の年度別使用回数

に関しては、ちょっとできなかったのですがSUMならあんまり重たくないかな?と思い
機器毎、使用場所毎の年度別使用回数で出たリストを使ってSUMで表示させるようにしました。

ちょっと仕事がばたついていて余裕がないので、繁忙期過ぎたらまたその部分もやり方を考えてみようと思います。

この度は、説明が下手だったにも関わらず根気よくお話を聞いていただいてありがとうございました!
これを機にもう少しマクロを勉強してみようと思います!
また、機会がありました際には懲りずに教えていただけると嬉しいです

隠居じーさんさんも
本当にありがとうございました!

時間がある時にほかの方々の物も眺めてみようと思います!
(はるはる) 2019/01/25(金) 09:37


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

無事に転記してそのシート内での表示等に変更して作れたのですが、

新たに表示シート2の修理依頼日を参照して隣のセルと2列を表示することはできないのか?
と聞かれまして、再度ご質問させていただきました。

教えていただいた通り下記のコードの数字を入れ替えて

 >If (x(8, j) >= MyDateA) * (x(8, j) <= MyDateB) Then

依頼日が年度内ならその列のセルを呼び出すことができているのですが、
一緒に隣も呼び出したいのです。

コードも大きく変更しないと難しいでしょうか?

(はるはる) 2019/01/29(火) 14:02


 こんばんは ^^
データゼロで終了しました。。。www
私のは駄作ですね。
お師匠様のおでましをお待ちいたしませう。
m(_ _)m

 でも
>>隣のセル
って
なんなのでせう?
でわ
(隠居じーさん) 2019/01/29(火) 22:34

 こんばんは!
 はるはる さん、、名前、、覚えちゃったよぉ、、、いつもは、、トピ主さん、、って言ってほとんど見てないんですけどね(笑)すみません。

 まぁ、、大した変更もありませんけど、、数合わせをしないといけないのと、、変更箇所が散らばってますから、、コードごと載せておきます。

 ところどころにコメントを入れてますから見てお勉強してください。

 隣にも対象のものがあると、だぶるけどね???、、まぁ、、、上司様とご相談して改造してください。。。

 いつまでもいると思うな、、親とSoulMan、、、なんちゃって、、、

 どうも切れが悪いな。。。。おやすみなさいzzzzzzzzzzzzzzz

 Option Explicit
Sub 表示シート2てすと2列一緒に()
Dim MyDic As Object
Dim MyAry() As Variant
Dim x As Variant
Dim MyTblA As Range
Dim MyTblB As Range
Dim MyDate As Long
Dim MyDateA As Date
Dim MyDateB As Date
Dim r As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim 最大値 As Long
Dim MyTimer As Single
MyTimer = Timer
MyDate = Sheets("表示シート").Range("C3").Value
MyDateA = DateSerial(MyDate, 4, 1)
MyDateB = DateSerial(MyDate + 1, 3, 31)
Set MyDic = CreateObject("Scripting.Dictionary")
With Sheets("データベース1")
    Set MyTblA = .Range("F4", .Range("F" & .Rows.Count).End(xlUp))
End With
For Each r In MyTblA
    If r.MergeCells Then
        If r.Address = r.MergeArea.Item(1).Address Then
            '数合わせで一つ余分に取得します。
            MyDic(r.Value) = r.Offset(, 2).Resize(9, r.CurrentRegion.Columns.Count - 6).Value
        End If
    End If
Next
With Sheets("表示シート2")
    Set MyTblB = .Range("A4", .Range("A" & .Rows.Count).End(xlUp))
    '2列にします
    k = 2
    ReDim MyAry(1 To MyTblB.Rows.Count + 8, 1 To k)
End With
For Each r In MyTblB
    If r.MergeCells Then
        If r.Address = r.MergeArea.Item(1).Address Then
            x = MyDic(r.Value)
            If IsArray(x) Then
                For j = LBound(x, 2) To UBound(x, 2)
                    '修理依頼日にしています
                    If (x(8, j) >= MyDateA) * (x(8, j) <= MyDateB) Then
                        If 最大値 < k Then 最大値 = k
                        ReDim Preserve MyAry(1 To MyTblB.Rows.Count + 8, 1 To 最大値)
                        For i = LBound(x, 1) To UBound(x, 1) - 1
                            'ここで2列分取得します
                            MyAry(i + n, k - 1) = x(i, j)
                            MyAry(i + n, k) = x(i, j + 1)
                        Next
                        '2列にします。
                        k = k + 2
                        '隣はすでに取得したのですっ飛ばします。
                        j = j + 1
                    End If
                Next
                n = n + 9
                '2列にします
                k = 2
            End If
        End If
    End If
Next
With Sheets("表示シート2")
    .Range("B4", .Range("B" & .Rows.Count).End(xlUp)).Offset(, 1). _
        Resize(.Range("A3").CurrentRegion.Rows.Count - 3, .Range("A3").CurrentRegion.Columns.Count - 2).ClearContents
    .Range("C4").Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
    .Range("A3").CurrentRegion.EntireColumn.AutoFit
End With
Set MyDic = Nothing
Set MyTblA = Nothing
Set MyTblB = Nothing
If IsArray(x) Then Erase x
Erase MyAry
MyTimer = Timer - MyTimer
MsgBox "処理が完了しました。" & vbCrLf & Format(MyTimer, "###0.000" & "秒")
End Sub
 隠居じーさん 様、、、いつもありがとうございます。m(__)m
(SoulMan) 2019/01/29(火) 23:11

 SoulManさん おはようございます。
こちらこそ。いつもお世話になっております。
ゲーム。。。おもしろそぉでしたね
あたり判定がむつかしそおですが。
あ!
すんまそ
このレスとは関係なかったですね。
いや〜、Dictionaryに9項目全データー、ほり込み可能なのですねぇえ
1レコードの中に9レコードみたいな感じで、すごいですね。
私では思いつきません。勉強になります。
140万件読込みスピードアップは配列と
Dictionaryで何とかなりましたですよ。
配列。。。とれびあ〜ん!(笑)
m(_ _)m

(隠居じーさん) 2019/01/30(水) 08:13


 だぶる話ですけど、、、もう既に取得したのでちょっとお行儀が悪いですけど、すっ飛ばせばいいだけでした。
 j = j + 1
 昨夜、投稿した後に気が付いたんですけど、、、眠たさに、、、勝てず、、、<(_ _*)>

 >140万件読込みスピードアップは配列と
 >Dictionaryで何とかなりましたですよ。

 それは素晴らしいですね。是非、、、Upしてください。(^^;

 >いや〜、Dictionaryに9項目全データー、ほり込み可能なのですねぇえ

 連想、、、配列なので、、関連付けているだけです。

 冬と言えば、、、みかん、、、
 夏と言えば、、、太陽、、、

 SoulManと言えば、、、、????、、、(一回で終わらない、、、おっい!!!(笑))

 みたいな、、、なんでも、、、、OKです。

 私らしい、、、と言えば、、、私らしい、、、あんまり考えないんですよね。。。ぱっとみてぱっと、、、

 はるはる さん、、、悩んでたりして(^^;

 では、では、
(SoulMan) 2019/01/30(水) 19:39

 >>それは素晴らしいですね。是非、、、Upしてください。(^^;
いえ。。。  m(_ _)m。。。( ̄▽ ̄;)
読込んだだけっす。。。読込んだ(必要な分だけ(年間)DICに ^^;;;。。。)
すみません。 とほほ〜 (笑)
^^
でわでわ

 はるはる さん すみません

(隠居じーさん) 2019/01/30(水) 21:37


SoulManさん
隠居じーさんさん

お疲れ様です。
すみません熱が出て寝てました…
インフルかと思ったらインフルじゃなくてすぐ復帰です…(涙)

コードありがとうございます!!!
変更すればいいか所も教えていただきありがとうございます!

どこを触って大丈夫なのかわからなかったのでとても助かります。
当面は上司とこの話ばかりになりそうなので、色々試してみようと思います!

(はるはる) 2019/01/31(木) 13:28


コメント返信:

[ 一覧(最新更新順) ]


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