• 締切済み

VBAの動的配列について

いつもお世話になっております。 エクセルVBAを学習中の者です。 動的配列についてお伺いします。 添付資料を見て頂きたいのですが、 シート名1~4に同一レイアウトの表があります。 これらの表をを2次元配列に格納し、その後、同一レイアウトのシートに一括転記したいと考えています。 転記の事を考えて、条件としては、 シート1から2行目以降のデータを配列『data』に格納、変数『dataCnt』が転記先の行番号と同じになるように考えています。 当初は、配列の定義を『Dim data(100,3) As Variant』と、多めに要素数を定義して、コードを記述していました。 正直、凄く気持ちが悪い感じでした・・・ 最近、動的配列を学習しまして、 シートごとにデータの行数を変数『lastRow』に格納して、配列を再定義して【データ数=要素数】とならないか? と思い、下記のようなコードを書いてみました。 が、『ReDim Preserve~』で実行エラーが発生してしまいます。 原因がなぜかわかりません! そもそも、動的配列はこのような使い方は出来ないのでしょうか? Sub テスト() Dim data() As Variant Dim x As Long Dim i As Long Dim ii As Long Dim lastRow As Long Dim dataCnt As Long dataCnt = 2 For x = 2 To 5 Worksheets(x).Activate lastRow = Cells(Rows.Count, 1).End(xlUp).Row If x = 2 Then ReDim data(2 To lastRow, 3) Else ReDim Preserve data(2 To dataCnt + lastRow - 1, 3) End If For i = 2 To lastRow For ii = 1 To 3 data(dataCnt, ii) = Cells(i, ii) Next ii dataCnt = dataCnt + 1 Next i Next x End Sub どなたかご指導をよろしくお願いいたします。

みんなの回答

  • nishi6
  • ベストアンサー率67% (869/1280)
回答No.2

基本的には動的配列の使い方(ReDim や Preserve)はあっています。 一つ残念なのは、要素数を変えることができるのは最後の変数です。 従って、変数をひっくり返します。 ReDim data(2 To lastRow, 3)   ↓ ReDim data(3, 2 To lastRow) ReDim Preserve data(2 To dataCnt + lastRow - 1, 3)   ↓ ReDim Preserve data(3, 2 To dataCnt + lastRow - 1) data(dataCnt, ii) = Cells(i, ii)   ↓ data(ii-1, dataCnt) = Cells(i, ii) インデックスはゼロからでしょう。 最後にシートに吐き出す時に、行列が列行の順になっているので、   Range(~:~) = Application.Transpose(data) のようにする必要があるでしょう。 確認する環境がなく、机上デバッグです。スペルミス等あればご容赦を。 基本的にはあっています。動かす変数の位置の問題でしょう。

  • chie65535
  • ベストアンサー率43% (8514/19356)
回答No.1

>『ReDim Preserve~』で実行エラーが発生してしまいます。 >原因がなぜかわかりません! 原因は「仕様だから」です。 >そもそも、動的配列はこのような使い方は出来ないのでしょうか? 仕様で「Reserveは静的配列にしか使えない。動的配列ではエラーになる」とハッキリと決まっています。 つまり「それは許されない」って事です。

genta1019boston
質問者

お礼

早速の回答ありがとうございます。 良く分からないので教えていただきたいのですが、 「動的配列の既存の値を消さないで要素数を変更するには、ReDim命令にPreserveキーワードを付ける」 という事だと思うのですが・・・ 仕様で「Reserveは静的配列にしか使えない。動的配列ではエラーになる」とハッキリと決まっています。 とはどういう事でしょうか?

関連するQ&A

  • 配列に格納したデータを指定行以下に転記する方法

    excel2000を使っています。 以下のコードだと最終行にデータが転記されます。これを4行目に確定して、転記したいのです。常に4行目つまりA列4行目以下に上書きしたいのです。 その場合コードをどのように変更すべきでしょうか? Sub 配列() With ActiveSheet ' 配列に格納 --------------------------- Dim i As Integer Dim LastRow As Long Dim SaleAry As Variant ' 配列に格納 --------------------------- SaleAry = Array(.Range("t4"), .Range("e5"), .Range("g5"), .Range("o5")) End With ' 転記 --------------------------- With Worksheets("daityou") LastRow = .Range("A65536").End(xlUp).Row For i = 0 To UBound(SaleAry) .Cells(LastRow + 1, i + 1).Value = SaleAry(i) ' Next i End With Set SaleAry = Nothing End Sub

  • VBAで、配列のデータをセルに書き戻す方法について

    1000行200列の配列があり、配列の5列目と6列目のデータを、セルの10列目と11列目にすばやく書き戻す方法を教えてください。 (方法1) Dim DATA() As Long ReDim DATA(1 To 1000, 1 To 200) FOR 行番号= 1 TO 1000 CELLS(行番号,10).VALUE = DATA(行番号,5) CELLS(行番号,11).VALUE = DATA(行番号,6) NEXT (方法2) Dim DATA() As Long ReDim DATA(1 To 1000, 1 To 200) Dim WORK1() As Long ReDim WORK1(1 To 1000, 1 To 1) Dim WORK2() As Long ReDim WORK2(1 To 1000, 1 To 1) FOR 行番号= 1 TO 1000 WORK1(行番号,1) = DATA(行番号,5) WORK2(行番号,1) = DATA(行番号,6) NEXT RANGE("J1:J1000").VALUE = WORK1() RANGE("K1:K1000").VALUE = WORK2() (方法1)より(方法2)の方が早いのですが、WORKに貯めるのもめんどうなので、 RANGE("J1:K1000").VALUE = DATA(1,5), DATA(2,5), DATA(3,5),~,DATA(999,6),DATA(1000,6)のようなことができればと思います。 よろしくお願いします。

  • 1次元配列をワークシートに高速で転記する方法について質問します。

    1次元配列をワークシートに高速で転記する方法について質問します。 エクセル2000です。 1000万までの範囲で素数を抽出したいと思いました。 そこで下記のようなコードを書きました。 最初は配列にいれず一個ずつセルに転記させたところ664,579個の素数抽出に1分37秒かかったので、配列を用意して下記のようにしたところ1分15秒まで短縮されました。 質問1:配列を使った割には劇的に短縮されないのはなぜでしょうか? 質問2:下記のコードでは最初に取り込んだ1次元外配列をシートに貼るために2次元に変換する際、2次元方向(列)は256で固定、1次元方向(行)は計算で求めたのですが、その結果、要素数が合わず、後の方のデータがない部分が0とシートに出てしまいます。 こうならない方法がありますか? 質問3:一次元配列をワークシートに配置するため二次元配列に変換するのに、もっと良い方法があったらご教示ください。 質問4:配列をワークシートに転記する場合   Application.ScreenUpdating = False   Application.Calculation = xlCalculationManual はあってもなくとも速度に変化がありませんでした。このような貼り付け(配列から一度に転記)には不要なのでしょうか? たくさん質問して申し訳ありません。 宜しくお願いいたします。 Sub test()   Dim t As Date   Dim a As Long, b As Long, c As Long, Num As Long, r As Long, i As Long, x As Long, y As Long   Dim buf As Boolean   Dim myPrm() As Long, myRng() As Long      t = Now()   c = 0   For Num = 2 To 10000000     a = Int(Sqr(Num)) '平方根算出     buf = True     For b = 2 To a '除数       If Num Mod b = 0 Then '割切れたら         buf = False '素数じゃない         Exit For       End If     Next b     If buf Then '割切れなかったら       ReDim Preserve myPrm(c) '添字追加       myPrm(c) = Num       c = c + 1 '素数カウント     End If   Next Num      r = Application.WorksheetFunction.RoundUp((UBound(myPrm) + 1) / 256, 0) '必要行数取得   ReDim myRng(1 To r, 1 To 256) '2次元配列のサイズ変更      For i = LBound(myPrm) To UBound(myPrm) '2次元配列に格納     x = IIf((i + 1) Mod 256 = 0, 256, (i + 1) Mod 256)     y = Application.WorksheetFunction.RoundUp((i + 1) / 256, 0)     myRng(y, x) = myPrm(i)   Next i      Application.ScreenUpdating = False   Application.Calculation = xlCalculationManual   Cells(1, 1).Resize(r, 256).Value = myRng() 'セル範囲に転記   Application.Calculation = xlCalculationAutomatic   Application.ScreenUpdating = True      MsgBox c & "個抽出しました。" & vbNewLine & "所要時間:" & Format(Now() - t, "hh:mm:ss") End Sub

  • 一括印刷vba エラー

    複数シートの印刷vbaを作成したのですが、インデックスが有効範囲ではありませんのエラーが発生します。該当部分のコードは以下のとおりで、配列変数に格納したシート名でシートを選択しようとするときにエラーとなります。 デバックで追ってみると、シート名の変数への格納も、配列変数の個数の宣言もきちんと入っているようなのですが・・・。 vbaは初心者で、基本的なこともあまりわからないレベルです。ヘルプやインターネットで調べても何が悪いのかよくわかりませんでした。 どこを直せばよいのか教えてもらえると助かります。 '連続印刷(1ファイル内のシート全てをひとかたまりで印刷) Dim Sh As Worksheet Dim AllShName() As Variant Dim x As Long For i = 1 To iRow Workbooks.Open Filename:=fil_path & ran1(i) & ".xlsx" x = 0 For Each Sh In ActiveWorkbook.Worksheets x = x + 1 ReDim Preserve AllShName(x) AllShName(x) = Sh.Name Next Worksheets(AllShName).Select   ← ここで「インデックスが有効範囲ではありません」のエラー ActiveWindow.SelectedSheets.PrintOut ActiveWindow.Close Next i End Sub

  • 二次元配列のVBA

    二次元配列のVBAの書き方がよくわからないのですが、 私が作ったサンプルプログラムのSub 二次元()において 二次元配列で表すにはどうすればいいのでしょうか? Sub 二次元()では 配列を格納する変数はtmpしか使っていませんが もう一つ配列を格納する用の変数を作ればいいのでしょうか? 数字とアルファベットは別々に取り出したいです。 ----------------------------------------------------- Sub 一次元() Dim myStr As String Dim tmp As Variant Dim i As Long For i = 1 To 5 myStr = myStr & "," & i Next myStr = Mid(myStr, 2) tmp = Split(myStr, ",") For i = LBound(tmp) To UBound(tmp) Debug.Print tmp(i) Next i End Sub Sub 二次元() Dim myStr As String Dim tmp As Variant Dim i As Long For i = 1 To 5 myStr = myStr & "," & i & "と" & Chr(64 + i) Next myStr = Mid(myStr, 2) tmp = Split(myStr, ",") For i = LBound(tmp) To UBound(tmp) Debug.Print tmp(i) Next i End Sub

  • AccessVBAで、二次元配列を動的に設定したい

    以下のコードにあるattrという配列に、DB上のとあるコードと名前を設定したいと思います。 DB上のデータ量は可変なので、データを取得するごとに動的に配列attrの要素数を動的に増やしたいと思っています。 検索等で色々と調べながら以下のコードを書いてみたのですが、どうもうまく動きません。 ご教授願います。 --------------------------------------------------- Dim attr() As String [loop start] ReDim Preserve attr(i, 0) ReDim Preserve attr(i, 1) attr(i, 0) = コード attr(i, 1) = 名前 [loop end]

  • ExcelのVBAの配列に関する質問です。

    ExcelのVBAの配列に関する質問です。 sheet1のデータをsheet2に表示するVBAを作成しています。。 sheet1のデータは7行目からスタートし、sheet2のデータは26行目からスタートしています。。 sheet1とsheet2の列は同じ並びではないため、それぞれのシートの列番号をCellsを用いて指定しています。 Sub test1() Dim endrow As Long endrow = Worksheets("sheet1").Range("A65536").End(xlUp).Row Dim i As Long Dim j As Long For i = 7 To endrow j = i + 19 Worksheets("sheet2").Cells(j, 1) = Worksheets("sheet1").Cells(i, 2) Worksheets("sheet2").Cells(j, 8) = Worksheets("sheet1").Cells(i, 28) Worksheets("sheet2").Cells(j, 9) = Worksheets("sheet1").Cells(i, 31) Worksheets("sheet2").Cells(j, 10) = Worksheets("sheet1").Cells(i, 32) ・ ・ ・ ※長いので省略 Next i End Sub 上記のtest1は正常に動くのですが、データ量が多いため、処理に時間がかかってしまいます。 高速化できないかと、以下のように変更しました。 Sub test2() Dim dataRange1 As Variant Dim dataRange2 As Variant dataRange1 = Worksheets("sheet1").Range("A1:GI10006") dataRange2 = Worksheets("sheet2").Range("A1:DZ10018") Dim endrow As Long endrow = Worksheets("sheet1").Range("A65536").End(xlUp).Row Dim i As Long Dim j As Long For i = 7 To endrow j = i + 19 dataRange2(j, 1) = dataRange1(i, 2) dataRange2(j, 8) = dataRange1(i, 28) dataRange2(j, 9) = dataRange1(i, 31) dataRange2(j, 10) = dataRange1(i, 32) ・ ・ ・ ※長いので省略 Next i End Sub test2は、エラーメッセージ等は表示されませんが、sheet2にデータが表示されません。 ちなみに、以下のようにsheet1のみ配列化した場合は、正常に表示されました。 Worksheets("sheet2").Cells(j, 1) = dataRange1(i, 2) Worksheets("sheet2").Cells(j, 8) = dataRange1(i, 28) Worksheets("sheet2").Cells(j, 9) = dataRange1(i, 31) Worksheets("sheet2").Cells(j, 10) = dataRange1(i, 32) test2は、どこが間違っているのでしょうか? ご教示ください。 よろしくお願いいたします。

  • VBAで配列に文字列が入らない?

    以下のように配列を設定し、A(ix)の配列にdo untilでそれぞれに文字列を入れようとしておりますが、うまくいきません。 dountil の一回目では代入ができているようですが、2回目ができずに止まってしまいます。 おかしな点がありましたらご指摘いただけませんでしょうか。 Dim A() As String Dim ix As Long ix = 0 ReDim Preserve A(ix) Dim tate As Long tate = 1 Do Until tate = 8 A(ix) = ws.Cells(tate, 1) tate = tate + 1 ix = ix + 1 Loop Doの初回A(0)に文字列は入りますが、 Doの二回目以降A(1)に文字列を入れる作業ができずに止まってしまいます。 よろしくお願いします。

  • EXCEL VBAの配列でわかりません。

    こんなコードがあるのですが、最後の他のシート(作業中シート)に書き込もうとするとエラーになってしまいます。”Sheets("作業中").”を抜くと同じシートに結果は返ってくるのですが…。コードの内容は、ある範囲のある列から空白ではないセルを探し出してその行のデータを配列で汲み取り、他のシートに一括で洗い出すというものです。 Sub 作業中() Dim myRow As Long Dim Data As Variant Dim WC() As Variant Dim WCE() As Variant myRow = Range("H1").CurrentRegion.Rows.Count Data = Range("H1:M" & myRow).Value For i = 1 To myRow If Data(i, 5) <> "" Then a = a + 1 Else b = b + 1 End If Next ReDim WC(a) ReDim WCE(b) c = 0 d = 0 For i = 1 To myRow If Data(i, 5) <> "" Then WC(c) = Range("H" & i & ":K" & i).Value c = c + 1 Else WCE(d) = Range(Cells(i, 8), Cells(i, 11)).Value d = d + 1 End If Next For i = 0 To a Range(Cells(i + 1, 15), Cells(i + 1, 18)).Value = WC(i) Next For i = 0 To b Range(Cells(i + 1, 19), Cells(i + 1, 22)).Value = WCE(i) Next e = Range(Cells(1, 15), Cells(a, 18)).Value Sheets("作業中").Range(Cells(1, 1), Cells(a, 4)).Value = e End Sub ちなみに同じシートから↓のコードを実行するとうまくいきます。 なぜ~??わからな~い??おしえてくださーい!! Sub test() Dim a As Variant a = Range("H1:K4") Sheets("作業中").Range("N1:Q4") = a End Sub

  • 行すべての値を張り付けるようにするには

    次の突合用マクロですが、照合番号だけでなく行すべてのデータを張り付けたいのですが、どの部分に変更を加えればよいかわかりません。 (添付画像をご覧ください) ・Sheet3~6にも列B~以降のデータを張り付けたい EntireRow Copy を使おうとしたのですが、どの様に行を指定すればよいかわかりませんでした。 ご教示頂ければ幸いです。 【準備して頂いたマクロ】 Sub TestX() Dim Sh1 As Worksheet, Sh2 As Worksheet Dim Sh3 As Worksheet, Sh4 As Worksheet Dim Sh5 As Worksheet, Sh6 As Worksheet Dim Sh1data As Variant, Sh2data As Variant Dim Sh3data As Variant, Sh4data As Variant Dim Sh5data As Variant, Sh6data As Variant Dim Sh1LastRow As Long, Sh2LastRow As Long Dim i As Long, j As Long, Sh5flg As Boolean Set Sh1 = Worksheets("Sheet1") Set Sh2 = Worksheets("Sheet2") Set Sh3 = Worksheets("Sheet3") Set Sh4 = Worksheets("Sheet4") Set Sh5 = Worksheets("Sheet5") Set Sh6 = Worksheets("Sheet6") ReDim Sh3data(0) ReDim Sh4data(0) ReDim Sh5data(0) ReDim Sh6data(0) Sh1LastRow = Sh1.Cells(Rows.Count, "A").End(xlUp).Row Sh2LastRow = Sh2.Cells(Rows.Count, "A").End(xlUp).Row Sh1data = Sh1.Range(Sh1.Cells(3, "A"), Sh1.Cells(Sh1LastRow, "B")).Value Sh2data = Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Sh2LastRow, "B")).Value For i = 1 To Sh1LastRow - 2 Sh5flg = False For j = 1 To Sh2LastRow - 2 If Sh1data(i, 1) = Sh2data(j, 1) Then If Sh2data(j, 2) <> "◯" Then Sh1data(i, 2) = "◯" Sh3data(UBound(Sh3data)) = Sh1data(i, 1) ReDim Preserve Sh3data(UBound(Sh3data) + 1) Sh2data(j, 2) = "◯" Else Sh5data(UBound(Sh5data)) = Sh1data(i, 1) ReDim Preserve Sh5data(UBound(Sh5data) + 1) Sh5flg = True End If Exit For End If Next j If Sh1data(i, 2) <> "◯" And Sh5flg = False Then Sh5data(UBound(Sh5data)) = Sh1data(i, 1) ReDim Preserve Sh5data(UBound(Sh5data) + 1) End If Next i For i = 1 To Sh2LastRow - 2 If Sh2data(i, 2) = "◯" Then Sh4data(UBound(Sh4data)) = Sh2data(i, 1) ReDim Preserve Sh4data(UBound(Sh4data) + 1) Else Sh6data(UBound(Sh6data)) = Sh2data(i, 1) ReDim Preserve Sh6data(UBound(Sh6data) + 1) End If Next Sh1.Range("A3").Resize(Sh1LastRow - 2, 2).Value = Sh1data Sh2.Range("A3").Resize(Sh2LastRow - 2, 2).Value = Sh2data Sh3.Range("A3").Resize(UBound(Sh3data), 1).Value = WorksheetFunction.Transpose(Sh3data) Sh4.Range("A3").Resize(UBound(Sh4data), 1).Value = WorksheetFunction.Transpose(Sh4data) Sh5.Range("A3").Resize(UBound(Sh5data), 1).Value = WorksheetFunction.Transpose(Sh5data) Sh6.Range("A3").Resize(UBound(Sh6data), 1).Value = WorksheetFunction.Transpose(Sh6data) Set Sh1 = Nothing Set Sh2 = Nothing Set Sh3 = Nothing Set Sh4 = Nothing Set Sh5 = Nothing Set Sh6 = Nothing End Sub

専門家に質問してみよう