Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Home : Excel 2016)
配列内へのセル値読み込みについてデータが保持されない。
投稿日時: 19/07/11 18:56:32
投稿者: torao

いつもお世話になっております。
 
現在
 
sh1にある帳票(複数行単位に個人データがある)データを
個人ごとに「直接配列へ取り込む」コードを作成したいと考えております。
 
(作業シートに一旦帳票からデータを書き出して配列に取り込む方法ではありません)
 
 
質問内容です
 
「配列の箱はループ分準備されているのですが、肝心な値が保持できない」
 
説明しますと・・・下の方のコード(一部抜粋です)ですが
 
    Dim v() As String,r As Long
    With sh1
        'r = 1 '転記先最終行
        For i = 4 To 244 Step 6 '最後のID行
            If .Cells(i + 1, 5).Value <> "" Then '氏名セルにデータが有れば処理
 
            ReDim v(r, 12)
 
                v(r, 0) = .Cells(i, 6).Value '
                v(r, 1) = .Cells(i + 1, 6).Value '
                v(r, 2) = .Cells(i + 1, 5).Value '
                v(r, 3) = .Cells(i + 1, 109).Value '
                v(r, 4) = .Cells(i + 1, 112).Value '
                v(r, 5) = .Cells(i + 2, 109).Value '
                v(r, 6) = .Cells(i + 2, 112).Value '
                v(r, 7) = .Cells(i + 4, 112).Value '
                v(r, 8) = .Cells(i + 3, 109).Value '
                v(r, 9) = .Cells(i + 3, 112).Value '
                v(r, 10) = .Cells(i + 5, 109).Value '
                v(r, 11) = .Cells(i + 5, 112).Value '
 
                r = r + 1
            End If
        Next i
    End With
 
 
v()にセル値を格納させております。
 
v(r, 12) 「r」は個人ごとに増加させています。
v(r, 12) 「12」は固定値です。
 
上記の設定で動作確認すると、配列内に取り込みは出来ているようですが・・・
 
例えば、「r」の人数が30人取り込むとすると
 
-v
└ v(0)
   └ v(0.0) ""
   └ v(0.1) ※〜11迄は以下省略
└ v(1)
   └ v(1.0) ""
   └ v(1.1) ※〜11迄は以下省略



 
└ v(29)
   └ v(29.0) "山田"
   └ v(29.1) ※〜11迄は以下省略
 
取り込み具合をデバッグで一つ一つ確認すると確かに読み込んでいるのですが
次の人を読み込むと上の配列内が=""空になってしましまい
 
※データが保持されておりません。
 
結局、ループ最後の人のデータのみが保持されており、v(0)〜v(28)のデータが全部空になっております。
 
 
すみませんが、アドバイスの程よろしくお願いします。
 

回答
投稿日時: 19/07/11 19:15:29
投稿者: Suzu

既存データを保持したまま要素数を変更したいのであれば
 Preserve を指定しないといけませんよね。

回答
投稿日時: 19/07/11 20:23:24
投稿者: simple

それと、以下のことを念頭に置いて下さい。
(1)
要素の数を増やせるのは、最後の次元だけです
v(r,c)のcだけが動的に増やせますが、rは増やせません。
軸をひっくり返した配列に書き込んでいって、
最後にtransposeする手があります。
(2)
また、
 v(1 to r,1 to 12)という宣言のしかたをすると、1から始まる配列にできます。

回答
投稿日時: 19/07/11 22:29:18
投稿者: simple

参考例文です。

Sub test()
    Dim v() As Long
    Dim vv  As Variant
    Dim i   As Long
    Dim r   As Long
    
    r = 1
    For i = 1 To 4
        ReDim Preserve v(1 To 3, 1 To r)
        v(1, r) = 0 + i  
        v(2, r) = 1 + i  
        v(3, r) = 2 + i  
        r = r + 1
    Next
    vv = Application.Transpose(v)
    'v  は Long(1 to 3 ,1 to 4)
    'vv は Long(1 to 4 ,1 to 3)
End Sub

投稿日時: 19/07/12 06:56:09
投稿者: torao

simple さま
 
ご報告です。
 
ありがとうございました。大変参考になりました。
 
ReDim Preserve v(1 To 12, 1 To r)で、列単位で配列に格納
 
vv = Application.Transpose(v)で、行単位で各行の値を格納
 
思い通りの格納ができました。
 
もう少し試したいと思います。

投稿日時: 19/07/12 07:04:05
投稿者: torao

今やっている処理はシート値は飛び飛びのセルですので
 
誤り→列単位で配列に格納
 
正し→セル値(項目)単位で配列に格納
 
でした、

投稿日時: 19/07/12 11:00:46
投稿者: torao

おかげさまで、先程まで配列に格納する部分は成功しました。
 
次に指定セル範囲に配列内の値を書き出す処理を作成しております。
 
    '▼集計Sheetへ配列内の「基礎データ」を個人行へ転記
 
この部分で
 
セル i 行の 6列〜14列に
 
配列 x 行の 4番目〜12番目の
 
値を転記しようと考えました。
一度は、ループして一つづつ転記しましたが時間がかかるため
 
幸い転記元と転記先のデータの並びが連続しているため、データを一括転記ができるのではと考えました。
 
そこで
 
'セル「6-14列目」は配列「4-12」と同じ項目で連続しているので一括転記
c.Offset(, 5).Resize(UBound(vv, 1), UBound(vv, 2)).Value = vv
 
としたところ x値で個人データを指定していないため配列内すべてが一括転記されました。(当然ですが)
 
(質問は)
 
配列の x値(個人) のみのデータ(4-12番目)を抜き出し転記する方法について
 
アドバイスの程よろしくおネがいします。

 
 
(現在のコード)
 
Sub 基礎データ作成()
    Dim sh1 As Worksheet: Set sh1 = Sheets("管理")
    Dim sh2 As Worksheet: Set sh2 = Sheets("集計")
    Dim i As Long, r As Long
    Application.ScreenUpdating = False
    '
    '▼管理表データの集計データを配列内に格納
    Dim v() As String, vv As Variant
    With sh1
        r = 1 '転記先最終行
        For i = 4 To 244 Step 6 '最後のID行
            If .Cells(i + 1, 5).Value <> "" Then '氏名セルにデータが有れば処理
                ReDim Preserve v(1 To 12, 1 To r) '行列配列設定と項目単位で配列格納
                v(1, r) = .Cells(i, 6).Value 'ID
                v(2, r) = .Cells(i + 1, 6).Value '番号
                v(3, r) = .Cells(i + 1, 5).Value '氏名
                v(4, r) = .Cells(i + 1, 109).Value
                v(5, r) = .Cells(i + 1, 112).Value
                v(6, r) = .Cells(i + 2, 109).Value
                v(7, r) = .Cells(i + 2, 112).Value
                v(8, r) = .Cells(i + 4, 112).Value
                v(9, r) = .Cells(i + 3, 109).Value
                v(10, r) = .Cells(i + 3, 112).Value
                v(11, r) = .Cells(i + 5, 109).Value
                v(12, r) = .Cells(i + 5, 112).Value
                r = r + 1
            End If
        Next i
        '行単位で列の値を格納し配列内で帳票形式に形成する
        vv = Application.Transpose(v)
    End With
    '
    '▼集計Sheetへ配列内の「基礎データ」を個人行へ転記
 
    Dim rr As Long, key As String, Result As Variant
    Dim x As Long, mySh As Range, c As Range
    With sh2
        r = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set mySh = .Range("A2:A" & r) '比較先ID列
        '実績セル範囲に処理月の総日数を転記
        Union(.Range("F2:P" & r), .Range("B2:B" & r)).Value = "" '一旦クリア
        Union(.Range("F2:F" & r), .Range("K2:K" & r), .Range("M2:N" & r)).Value = sh1.Range("DH2").Value
    End With
    '転記処理
    For Each c In mySh
        key = c.Cells(1, 1) '集計のID番号格納
        For x = LBound(vv) To UBound(vv)
            If vv(x, 1) = key Then '配列内のID番号検索
                '一致した場合は配列内をセルに書き出し
                 
                c.Cells(1, 2).Value = vv(x, 2) '番号
 
        'セル「6-14列目」は配列「4-12」と同じ項目で連続しているので一括転記
                c.Offset(, 5).Resize(UBound(vv, 1), UBound(vv, 2)).Value = vv
 
                'IDがあれば着色
                c.Cells(1, 1).Interior.ColorIndex = 6
            End If
        Next x
    Next c
    Application.ScreenUpdating = True
End Sub

投稿日時: 19/07/12 16:51:39
投稿者: torao

追伸です
 
分からなかったので、別案でベタに処理してみました。
 
一応転記は出来ました。
当初は5秒位かかっていましたが、1-2秒位で処理できました。
ただ、配列の項目をループで一つ一つ格納しているので時間はかかりますが・・・
 
(もう少し速くなれば・・・)
 
(転記処理部分抜粋)
 
・「key」検索値IDを「vv」配列内で検索し
・ヒットしたら転記用の配列「mList」に個人データ全てを格納し
・セルに個人行範囲に一括で書き出す。
 
    '▼集計Sheetへ配列内の「基礎データ」を個人行へ転記
    Dim rr As Long, key As String, Result As Variant
    Dim x As Long, y As Long, mySh As Range, c As Range
    With sh2
        r = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set mySh = .Range("A2:A" & r) '比較先ID列
        '集計の実績セル範囲に処理月の総日数を転記
        .Range("A2:A" & r).Interior.ColorIndex = 0
        Union(.Range("F2:P" & r), .Range("B2:B" & r)).Value = "" '一旦クリア
        Union(.Range("F2:F" & r), .Range("K2:K" & r), .Range("M2:N" & r)).Value = sh1.Range("DH2").Value
    End With
    '転記処理
    Dim flag As Boolean 'keyが配列内にあるか判定
    Dim mList() As String: '文字列として読み込む
    For Each c In mySh
        '個人ごとにフラグと転記用配列をクリア
        flag = False
        ReDim mList(0)
        key = c.Cells(1, 1) '請_集計のID番号格納
        For x = LBound(vv) To UBound(vv)
            If vv(x, 1) = key Then '配列内のID番号検索
                flag = True
                Exit For 'ヒットすれば抜ける
            End If
        Next x
        'フラグ判定:検索値があれば転記用の配列に格納して転記
        If flag = True Then
            For y = 4 To 12
                '配列4-12番迄格納
                mList(UBound(mList)) = vv(x, y)
                ReDim Preserve mList(UBound(mList) + 1)
            Next y
            c.Cells(1, 2).Value = vv(x, 2) '移動番号
            c.Offset(, 5).Resize(, 9).Value = mList '
        End If
    Next c
    Application.ScreenUpdating = True
End Sub

回答
投稿日時: 19/07/15 13:18:31
投稿者: Suzu

配列にするのは、Excelを操作するにおいて遅い操作【セルに書き込む】動作の回数を減らす為に使います。
 
こんかいは、1行毎に配列の値を張り付けていますが
検索結果、張り付けたい 行方向 も含め全てを配列に入れてしまい
配列まるっと(行/列全て)を張り付ける 動作にすると高速化が見込めます。
 
 
配列内で検索が面倒&検索元の行数が少ないのであれば、
元の配列を1発で張り付けてしまい
フィルターオプションにて、検索結果のみ取得してしまい
改めて コピペ で値貼り付けを行い元の張り付けていたデータを消してしまうとか。

投稿日時: 19/07/15 17:27:10
投稿者: torao

Suzuさま
 
ありがとうございます。
配列の理解不足で、どうすればよいかアイディアが出てこなくて困っていたところです。
 
調べながら、私のスキルで手に負えるかシートの構成とにらめっこしてみます。

回答
投稿日時: 19/07/16 11:58:46
投稿者: Suzu

検索後の値を配列に持たせる事はそんなに難しい話ではないですよ。
シート構成も関係ないと思います。
 
サンプルでは、検索値を Sheet2に持たせています。
 
vv は 行列を入れ替えずに 検索結果を持たせる為の配列
vvvを 行列を入れ替え、Excel転記用としています。
 
適宜修正ください。
 
 

Sub test()
Dim v     As Variant
Dim vv()  As String
Dim vvv   As Variant
Dim i     As Long
Dim j     As Long
Dim k     As Long

Dim rng   As Range

'"Sheet1" A1:E〜 データ範囲 各セルにセルアドレスを値として入力済
'                    テスト時 A1 から、E4 を使用

'"Sheet2" A1:A〜 Sheet1のA列値との比較データ
'                    テスト時、A1からA3に、"A2","A4","A5" を入力

'"Sheet3" 出力先シート

v = Application.Transpose(Sheet1.Range("A1:E" & Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row))

'---------------ここから先を参考にどうぞ。
k = 0
For Each rng In Sheet2.Range("A1:A" & Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Row)
  For i = LBound(v, 2) To UBound(v, 2)
    If rng.Value = v(1, i) Then
      k = k + 1
      ReDim Preserve vv(1 To 5, 1 To k)
      For j = 1 To 5
        vv(j, k) = v(j, i)
      Next j
      Exit For
    End If
  Next
Next rng

vvv = Application.Transpose(vv)
Sheet3.Range(Sheet3.Cells(1, 1), Sheet3.Cells(UBound(vvv, 1), UBound(vvv, 2))).Value = vvv
End Sub

 
・セルの値をそのまま参照
・検索は総当たり(ヒットすれば抜ける)
 
で行っていますので。。
検索値(ここで言うSheet2)の件数が多い場合は上記二つも改善の余地があるでしょうね。

投稿日時: 19/07/17 09:02:21
投稿者: torao

Suzuさま 取り急ぎご報告です
 
ありがとうございました(^O^)/
 
今まで理解できなかった、配列から配列への格納の構造が分かりました
これをやりたかったのです!!
 
検索値の指定方法を変えれば、コード内でほぼ処理が完了してしまうのでありがたいです
 
サンプルを元に実務ファイルへの導入を試してみます
 
Sub test()
Dim v As Variant '元データ
Dim vv() As Variant '検索結果用
Dim vvv As Variant '結果をSheet構成にあわせて変換
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Variant
 
'▼(基データ格納) 項目行を除くデータ範囲格納
v = Application.Transpose(Sheet1.Range("A2:F" & Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row))
 
'▼(検索値を格納)
Dim Key_Arr As Variant
Key_Arr = Array(1, "A", "B", "E", "H")'※「1」はリストに存在しない値
'検索値を順番に処理
k = 0
For Each n In Key_Arr
'配列v内の2次元目内に
  For i = LBound(v, 2) To UBound(v, 2)
  '検索値と配列vの値が一致したら
    If n = v(1, i) Then
    '---(結果格納) 配列vvを準備(列5個=固定とする、値kは動的に追加)
      k = k + 1
      ReDim Preserve vv(1 To 5, 1 To k)
      '結果を一旦指定の列分を行単位で格納
      For j = 1 To 5
        vv(j, k) = v(j, i)
      Next j
      '処理完了後抜けて次に
      Exit For
    End If
  Next
Next n
'---(変換) 結果を格納したvv内データを行列入替えて格納しなおす
vvv = Application.Transpose(vv)
'▼(出力) 指定シートへ1行目を起点に下に1行offsetした位置に転記
Sheet3.Range(Sheet3.Cells(1, 1), Sheet3.Cells(UBound(vvv, 1), UBound(vvv, 2))).Offset(1, 0).Value = vvv
End Sub

回答
投稿日時: 19/07/17 13:13:00
投稿者: Suzu

引用:
今まで理解できなかった、配列から配列への格納の構造が分かりました
これをやりたかったのです!!
  
検索値の指定方法を変えれば、コード内でほぼ処理が完了してしまうのでありがたいです

 
格納のしかたって事ですかね。
 
 
  
処理速度の向上を検討するなら、検索方法のアルゴリズムの検討
(二分検索の適用とか。その為には並べ替えが必要)となるでしょうが、
コスト(コード作成にかかる時間の増加)/メリット(処理時間の減少) の天秤を掛けた時
処理時間が 既に 1〜2秒となっているのであればコスト側が勝ってしまいますよね。
知的好奇心からの追及であれば、検討をどうぞ。

回答
投稿日時: 19/07/17 19:59:00
投稿者: mattuwan44

やりたいことは、こういうことですかね?
 

Option Explicit

Sub test()
    Dim sht管理 As Worksheet: Set sht管理 = Sheets("管理")
    Dim sht集計 As Worksheet: Set sht集計 = Sheets("集計")
    Dim vntList() As Variant
    Dim vntResult() As Variant
    Dim i As Long
    Dim iMax As Long
    Dim c As Range
    Const n As Long = 6

    vntList = sht管理.Range("A4:A244").Resize(, 112).Value
    iMax = UBound(vntList, 1)
    ReDim vntResult(1 To (iMax + 1) \ n, 12)

    For i = LBound(vntList, 1) To iMax Step n
        vntResult(i + 1, 1) = vntList(i, 6)
        vntResult(i + 1, 2) = vntList(i + 1, 6)
        vntResult(i + 1, 3) = vntList(i + 1, 5)
        vntResult(i + 1, 4) = vntList(i + 1, 109)
        vntResult(i + 1, 5) = vntList(i + 1, 112)
        vntResult(i + 1, 6) = vntList(i + 2, 109)
        vntResult(i + 1, 7) = vntList(i + 2, 112)
        vntResult(i + 1, 8) = vntList(i + 4, 112)
        vntResult(i + 1, 9) = vntList(i + 3, 109)
        vntResult(i + 1, 10) = vntList(i + 3, 112)
        vntResult(i + 1, 11) = vntList(i + 5, 109)
        vntResult(i + 1, 12) = vntList(i + 5, 112)
    Next

    vntList = WorksheetFunction.Index(vntResult, 0, 1)
    With sht集計.Range("A1").CurrentRegion
        With Intersect(.Columns(1), .Offset(1))
            For Each c In .Cells
                i = 0
                On Error Resume Next
                i = WorksheetFunction.Match(c.Value, vntList, 0)
                On Error GoTo 0
                If i > 0 Then
                    vntList(i) = WorksheetFunction.Index(vntResult, i, 0)
                End If
            Next
        End With
        .Resize(, 12).Offset(1).Value = WorksheetFunction.Transpose( _
                                        WorksheetFunction.Transpose(vntList))
    End With
End Sub

 
動作確認してません。まともに動かないかもです^^;
列数の「12」も定数化できそうですが、
まずは動くか。
次に高速化できたか。
が確認出来てから、もうちょいメンテナンス性を考える感じですかね^^;;
 
ってか、数式だと遅いんですかね?
数式の方が速い可能性はないですかね?

投稿日時: 19/07/18 11:45:20
投稿者: torao

mattuwan44 さま
 
MATCH関数を使用したコードでループを使わずに検索する方法ありがとうございます。
 
質問なのですが
 
色々と試しているうちにわからないことがありまして・・・
 
配列内の要素内データ「あいうえお」が格納されている場合で
このうち、「い〜お」のみをセルに書き出す場合の記述方法をご教授いただけないでしょうか
 
-mList
└mList(1) "あ"
└mList(2) "い"
└mList(3) "う"
└mList(4) "え"
└mList(5) "お"
 
ループを使用して必要な要素のみを格納することはわかっているのですが
 
下記のように一括で格納する方法はありますでしょうか?
 
test=mList(1,2),Resize(1,5)
 
すみません、よろしくお願いします。

回答
投稿日時: 19/07/18 15:04:09
投稿者: Suzu

Excel のセルへ 配列を渡す際には 2次元配列そのモノを渡す必要があります。
 
その上で、ここからここまで の様な渡し方は、、ないと思います。
 
上記を踏まえると 方法はふたつ。
 
1. 全てを セルに渡したのち、不要な 行なり列を削除
 
2. 配列の段階で不要な部分を削除
    方法としては 不要なインデックス以降の部分を不要な部分へ値を代入
    ReDimを使い次元変更

  Dim mList() As Variant
  Dim i As Lon
  Dim j As Long

  Let mList = Array("あ", "い", "う", "え", "お")

  i = 1   '配列インデックス 1 を排除
  For j = i To UBound(mList) - 1
    mList(j) = mList(j + 1)
  Next j

  ReDim Preserve mList(UBound(mList) - 1)

  Cells(1, 1).Resize(1, UBound(mList) + 1).Value = mList()

投稿日時: 19/07/18 15:17:51
投稿者: torao

Suzu さま
 
ありがとうございます。
スッキリしました。
 
色々とネットで可能性を探っていたところでした。
 
これで、皆様から頂いたアドバイスを元に前に進めます。

投稿日時: 19/07/19 09:22:26
投稿者: torao

回答頂いた皆様ありがとうございました。
 
配列について、とても勉強になりました。
いままで、作成してきたファイルのコードを少しづつUpdateしていきたいと思います。