戻る  □一般操作のサロン  □ 使用方法  □ 新着記事  □ 新規に質問する!  □ トピック一覧  □ 検索  □ 過去ログ
[ 最新記事及び返信フォームをトピックトップへ ]
このトピック参照回数 :
値転記の時間短縮

    [191693] 値転記の時間短縮-

    ■親トピック/記事引用/メール受信=OFF■

    □投稿者/ みらくる -(2020/04/05(21:00))
    □U R L/
      いつもお世話になっています。
      今回は、値転記の時間短縮についてご教授お願いします。
      
      現在、下記のコードで私のパソコンでは5分かかりますが、短縮できる方法
      があれば教えてください。
      (ファイルを開いた時点のイベントで、計算方法は手動としています)
      
      マクロの処理内容は、以下のとおりです。
      
      ・アクティブの方法で値転記(転記先、転記元シート共に上の行から1行毎に1列づつ右へ処理)
      ・転記元のデータは999と任意の数字(≒20.0001〜49.9999の範囲)
      ・転記元データが999の場合は転記先は空欄とし、999以外は元の値を転記
          
      ・転記元シートの転記範囲:B2〜AC77444(サイズ77443行×28列)
      ・転記元シートのデータは43行毎(1ブロック)に最後に空欄セルが3つあり(AA〜AC列)
      ・転記元シートのデータ数=77443×28-(77443÷43)×3=2163001セル
          
      ・転記先シートの転記範囲:D6〜ATH1806(サイズ1801行×1201列)
      ・転記先シートのデータ数=1201×1801=2163001セル
      
      Option Explicit
      
      Sub 値転記()
         
          '画面更新のOFF
          Application.ScreenUpdating = False
      
          Dim i As Long
          Dim j As Long
          Dim mosheet As Worksheet
          Dim sasheet As Worksheet
          Set mosheet = Worksheets(3)            '転記元シート
          Set sasheet = Worksheets("転記先")     '転記先シート
      
          sasheet.Activate
          Range("D6:ATH1806").ClearContents  '前回の転記先データの一括クリア
          Range("D6").Activate
      
          'アクティブの方法で値転記(転記先、転記元シート共に上の行から1行毎に1列づつ右へ処理)
          '転記元のデータは999と任意の数字(≒20.0001〜49.9999の範囲)
          '転記元データが999の場合は転記先は空欄とし、999以外は元の値を転記
          
          '転記元シートの転記範囲:B2〜AC77444(サイズ77443行×28列)
          '転記元シートのデータは43行毎(1ブロック)に最後に空欄セルが3つあり(AA〜AC列)
          '転記元シートのデータ数=77443×28-(77443÷43)×3=2163001セル
          
          '転記先シートの転記範囲:D6〜ATH1806(サイズ1801行×1201列)
          '転記先シートのデータ数=1201×1801=2163001セル
          
          i = 2
          Do Until i > 77444
              j = 2
              Do Until j > 29
          
                  '転記元シートの処理セルが空欄の場合(43行毎のAA列の位置)は次の行に移行
                  If mosheet.Cells(i, j).Value = "" Then
                  Exit Do
                  
                  '転記先シートは次の行に移行位置(ATI列)で、転記元シートの処理セルが「999」でない場合、
                  '次の行の最初の列に移動して値転記とする
                  ElseIf ActiveCell.Offset(0, 1).Value <> "" And mosheet.Cells(i, j).Value <> "999" Then
                  ActiveCell.Offset(1, -1201).Activate
                  ActiveCell.Value = mosheet.Cells(i, j).Value
                  ActiveCell.Offset(0, 1).Activate
                  
                  '転記先シートは次の行に移行位置(ATI列)で、転記元シートの処理セルが「999」の場合、
                  '次の行の最初の列に移動して空欄とする
                  ElseIf ActiveCell.Offset(0, 1).Value <> "" And mosheet.Cells(i, j).Value = "999" Then
                  ActiveCell.Offset(1, -1201).Activate
                  ActiveCell.Value = ""
                  ActiveCell.Offset(0, 1).Activate
                   
                  '(転記先シートは処理行の途中位置)転記元シートの処理セルが「999」でない場合、値転記とする
                  ElseIf mosheet.Cells(i, j).Value <> "999" Then
                  ActiveCell.Value = mosheet.Cells(i, j).Value
                  ActiveCell.Offset(0, 1).Activate
                    
                  '(転記先シートは処理行の途中位置)転記元シートの処理セルが「999」の場合、空欄とする
                  ElseIf mosheet.Cells(i, j).Value = "999" Then
                  ActiveCell.Value = ""
                  ActiveCell.Offset(0, 1).Activate
                 
                  End If
          
              j = j + 1
              Loop
          i = i + 1
          Loop
          
          '画面更新のON
          Application.ScreenUpdating = True
          
      End Sub
      
      
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191694] Re[1]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ γ -(2020/04/06(02:05))
    □U R L/
      ActiveCellを多用するとどうしても遅くなります。
      
      配列を利用して、配列上で計算し、
      ワークシートとのやりとり(特に書き込み)を、
      セル単位でなく一括して実行するようにすれば、高速化できます。
      参考にして下さい。
      
      7秒くらいで済むはずです。
      
      Sub 値転記Ver2()
          Dim wsS  As Worksheet
          Dim wsD  As Worksheet
          Dim i    As Long
          Dim j    As Long
          Dim r    As Long
          Dim c    As Long
          Dim matS As Variant
          Dim matD As Variant
          Dim lastCol As Long
          
          Dim t
          t = Timer
          
          Application.ScreenUpdating = False
          Application.Calculation = xlCalculationManual
          
          Set wsS = Worksheets(3)            '転記元シート
          Set wsD = Worksheets("転記先")     '転記先シート
      
          wsD.Range("D6:ATH1806").ClearContents  '前回の転記先データの一括クリア
          
          matS = wsS.Range("B2:AC77444").Value
          matD = wsD.Range("D6:ATH1806").Value
          lastCol = UBound(matD, 2)
          
          r = 1: c = 1    '書込先の配列のインデックス(r行,c列)
          For i = 1 To UBound(matS, 1)
              For j = 1 To UBound(matS, 2)
                  If matS(i, j) <> "" Then
                      '転記
                      If matS(i, j) <> "999" Then
                          matD(r, c) = matS(i, j)
                      Else
                          matD(r, c) = ""
                      End If
                      
                      'インデックスの更新
                      If c = lastCol Then
                          r = r + 1
                          c = 1
                      Else
                          c = c + 1
                      End If
                  End If
              Next
          Next
          
          'ワークシートに転記
          wsD.Range("D6").Resize(UBound(matD, 1), UBound(matD, 2)).Value = matD
      
          '画面更新のON
          Application.ScreenUpdating = True
          Application.Calculation = xlCalculationAutomatic
          Debug.Print Timer - t; "   配列利用"
      End Sub
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191695] Re[2]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ みらくる -(2020/04/06(19:48))
    □U R L/

      γ様
      ご回答誠にありがとうございました。

      γ様のコードを実行しましたら、7秒で転記が完了しました。
      私のコード転記結果とγ様コード転記結果を全てIFで比較しましたら完全に一致
      しました。
      目から鱗、びっくりの速さです!感謝です。

      今後γ様のコードを使用したいと思いますが、その前にコードの意味を調べて
      みたいと思います。
      分からない点等質問したいと思いますが、よろしくお願いいたします。
      コードの意味を理解(可能なら)してから解決にチェック入れたいと思います。




    [191697] Re[3]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ まっつわん -(2020/04/07(11:32))
    □U R L/
      こんなのは遅いですかねぇ。。。。
      セルの位置は決め打ちでよさそうですかねぇ。。。
      
      Option Explicit
      
      Sub test()
          Dim rngold As Range
          Dim rngNew As Range
          Dim a As Range
          Dim ix As Long
          Dim t
          
          t = Timer
          
          Set rngold = Worksheets(1).Range("A1:D4,A8:D11,A15:D18")
          Set rngNew = Worksheets(2).Range("A1:H2,A6:H7,A11:H12")
          rngNew.ClearContents
          
          For Each a In rngold.Areas
              ix = ix + 1
              test2 a, rngNew.Areas(ix)
          Next
          
          rngNew.Replace "999", ""
          
          MsgBox Timer - t & "秒"
      End Sub
      
      Function test2(rngold As Range, rngNew As Range)
          Dim v, vv, e
          Dim i As Long, j As Long, k As Long
      
          v = WorksheetFunction.Transpose(rngold)
          vv = rngNew
          k = UBound(vv, 2)
      
          i = 1
          For Each e In v
              j = j + 1
              If j > k Then
                  i = 1 + 1
                  j = 1
              End If
              vv(i, j) = e
          Next
          
          rngNew = vv
      End Function
      
      セル範囲が広すぎて数をよく数えれないので、
      1画面の中で動作確認出来そうなデータ数にしてます。
      参考になれば。


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191698] Re[4]: 値転記の時間短縮-

    解決!!ありがとうございました! / 記事引用/メール受信=OFF■

    □投稿者/ みらくる -(2020/04/07(20:21))
    □U R L/
      配列についてネットを調べましたら、γ様のコードが理解できました。
      今回のような莫大なデータの転記には配列は威力を発揮すると思いました。
      
      備忘録も兼ねてγ様のコードにコメントを追加しました。
      コメントの考え方が間違っていましたらご指摘願います。
      また、繰返しはDoUntilが好きなので、以下のコードに変更しました。
      マクロ所要時間、転記結果は変更前後と同じでした。
      
      まっつわん様
      ご回答ありがとうございました。
      今の自分には難しいコードですが、今後時間の空いた時に理解できるように
      したいと思います(可能なら)。ありがとうございました。
      
      Sub 値転記Ver2()
          Dim wsS  As Worksheet
          Dim wsD  As Worksheet
          Dim i    As Long    '転記元 配列の行インデックス
          Dim j    As Long    '転記元 配列の列インデックス
          Dim r    As Long    '転記先 配列の行インデックス
          Dim c    As Long    '転記先 配列の列インデックス
          Dim matS As Variant    '転記元の配列
          Dim matD As Variant    '転記先の配列
          Dim lastCol As Long    '転記先の配列の列数
          
          Dim t
          t = Timer
          
          Application.ScreenUpdating = False
          Application.Calculation = xlCalculationManual
          
          Set wsS = Worksheets(3)            '転記元シート
          Set wsD = Worksheets("転記先")     '転記先シート
      
          wsD.Range("D6:ATH1806").ClearContents  '前回の転記先データの一括クリア
          
          matS = wsS.Range("B2:AC77444").Value    '転記元の配列
          matD = wsD.Range("D6:ATH1806").Value    '転記先の配列
          
          lastCol = UBound(matD, 2)   'UBound関数は配列のサイズを返す(1=行、2=列)
          
          r = 1: c = 1    '転記先の配列のインデックス(r行,c列)
          i = 1
          Do Until i > UBound(matS, 1)   '配列の行数77443を超えるまで繰返し
              j = 1
              Do Until j > UBound(matS, 2)    '配列の列数28を超えるまで繰返し
              
                  If matS(i, j) <> "" Then    '転記元が空欄の場合は転記しない
                      
                      '転記
                      If matS(i, j) <> "999" Then
                          matD(r, c) = matS(i, j)
                      Else
                          matD(r, c) = ""
                      End If
                      
                      'インデックスの更新
                      If c = lastCol Then
                          r = r + 1
                          c = 1
                      Else
                          c = c + 1
                      End If
                      
                  End If
              j = j + 1
              Loop
          i = i + 1
          Loop
          
          '配列からワークシートへ一度に転記
          wsD.Range("D6").Resize(UBound(matD, 1), UBound(matD, 2)).Value = matD
      
          '画面更新のON
          Application.ScreenUpdating = True
          
          'マクロ所要時間の表示(イミディエイト画面)
          Debug.Print Timer - t; "   配列利用"
          
      End Sub
      
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191699] Re[5]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ γ -(2020/04/07(22:01))
    □U R L/
      直交しているべき転記とIndexの更新の話を、
      混ぜ合わせているところが、まずは大きな要改善点でした。
      配列を使わないあなたのコードでも、そこを直せば半分くらいの時間になります。
      そのあたりは、今後とも参考にすべき話かと思いました。
      配列利用は効果は大きいですが、基本部分もお忘れ無く。
      
      読まれている方が誤解(For ..NextよりDo..Loopを使うべきなどと)してはいけないので、
      バランス上申し上げておきます。
      
      私は、
          i = 2
          Do Until i > 77444
              j = 2
              Do Until j > 29
                  処理
              j = j + 1
              Loop
          i = i + 1
          Loop            
      
      よりも
      
          For i = 2 To 77444
              For j = 2 To 29
                  処理
              Next
          Next
      
      のほうが余分なインクリメント(1加算)も抽象化できますし、
      繰り返しの上限下限が明確ですから、意味も把握しやすいので、
      こちらを優先すべきと思います。
      
      Do Loopは、時に無限ループの危険もありますから、
      予め終了が特定出来ない場合などに限定すべきでしょう。
      すべてをDo Loopで書くと言う方は、極めて少数だと思います。(私は初めて会いました)
      
      なお、仮に書くとしても、そもそもインデントはこうでしょう。
          i = 2
          Do Until i > 77444
              j = 2
              Do Until j > 29
                  処理
                  j = j + 1
              Loop
              i = i + 1
          Loop            
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191700] Re[6]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ みらくる -(2020/04/07(22:45))
    □U R L/
      γ様
      繰返し文についてのご指摘ありがとうございます。
      DoUntilは、自分がただ好きなだけで、それを他の方に勧めているわけではありま
      せんのであしからず。
      
      >直交しているべき転記とIndexの更新の話を、
      混ぜ合わせているところが、まずは大きな要改善点でした。
      配列を使わないあなたのコードでも、そこを直せば半分くらいの時間になります。
      
      具体的に改善点を教えていただけますでしょうか。
      よろしくお願いいたします。
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191701] Re[7]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ γ -(2020/04/07(22:46))
    □U R L/

      もう既にコードとして書いています。




    [191705] Re[8]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ みらくる -(2020/04/08(19:46))
    □U R L/
      γ様
      
      >もう既にコードとして書いています。
      
      了解いたしました。
      γ様のコードの転記方法(転記元、転記先でインデックス使用)は配列専用の方法と
      思っていましたが、配列を使わない方法にも使えるとは知りませんでした。
      今まで、転記はアクティブの方法しか知りませんでしたので大変勉強になりま
      した。ありがとうございました。
      
      γ様のコードのインデックスの数字を配列基準からセル番号基準に変更し、配列
      を使わない方法で以下のコードとしましたら130秒位で完了しました。アクティブ
      の転記方法に比べ60%程度短縮できました。
      
      Sub 値転記Ver2()
          Dim wsS  As Worksheet
          Dim wsD  As Worksheet
          Dim i    As Long
          Dim j    As Long
          Dim r    As Long
          Dim c    As Long
          'Dim matS As Variant    ’配列部分はコメントに変更(以下同様)
          'Dim matD As Variant
          Dim lastCol As Long
          
          Dim t
          t = Timer
          
          Application.ScreenUpdating = False
          Application.Calculation = xlCalculationManual
          
          Set wsS = Worksheets(3)            '転記元シート
          Set wsD = Worksheets("転記先")     '転記先シート
      
          wsD.Range("D6:ATH1806").ClearContents  '前回の転記先データの一括クリア
          
          'matS = wsS.Range("B2:AC77444").Value
          'matD = wsD.Range("D6:ATH1806").Value
          lastCol = 1204   '転記先の列インデックス右端位置
          
          r = 6: c = 4        '転記先のセルのインデックス(r行,c列)
          For i = 2 To 77444   '転記元の行インデックス
              For j = 2 To 29   '転記元の列インデックス
                  If wsS.Cells(i, j).Value <> "" Then    '転記元が空欄でない場合に転記
                      '転記
                      If wsS.Cells(i, j).Value <> "999" Then
                          wsD.Cells(r, c).Value = wsS.Cells(i, j).Value
                      Else
                          wsD.Cells(r, c).Value = ""
                      End If
                      
                      'インデックスの更新
                      If c = lastCol Then    '転記先が右端位置なら
                          r = r + 1        '次の行に移行
                          c = 4          '左端に移行
                      Else
                          c = c + 1    '途中の列なら右へ移行
                      End If
                  End If
              Next j
          Next i
          
          'ワークシートに転記
          'wsD.Range("D6").Resize(1801, 1201).Value = matD
          '上と同じ操作   wsD.Range("D6").Resize(UBound(matD, 1), UBound(matD, 2)).Value = matD
          
          '画面更新のON
          Application.ScreenUpdating = True
          Application.Calculation = xlCalculationAutomatic
          Debug.Print Timer - t; "   配列なし"
      End Sub
      
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191706] Re[9]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ γ -(2020/04/08(21:27))
    □U R L/
      最後に、ちょっとしたTipsを追記しておきます。(別のところでも書きましたが)
      
      If ActiveCell.Offset(0, 1).Value <> "" And mosheet.Cells(i, j).Value <> "999" Then
      と書いたとき、
      第一の条件が Falseのとき(たいていはFalseです)、
      2つ目以降がなんであれ、結果は False に決まっていますから、
      多くのプログラム言語では、二つ目以降の条件は評価しないのが普通です。
      これは「短絡評価」と呼ばれます。(詳細は、Wikipediaを調べてください)
      
      しかし、VBAでは短絡評価方式は採らず、すべての条件を律儀に評価してしまいます。
      言語仕様としてかなり珍しい部類です。無駄と言えば無駄です。
      従って、速度を考える場合は、And を安易に繋げない方が有利になります。
      
      例えば、下のような書き方のほうが速度的には有利になるはずです。
      今回は、その部分は大きくないかもしれないが、覚えて置くとよいでしょう。
      
      If ActiveCell.Offset(0, 1).Value <> "" Then
          If mosheet.Cells(i, j).Value <> "999" Then
              ActiveCell.Offset(1, -1201).Activate
              ActiveCell.Value = mosheet.Cells(i, j).Value
              ActiveCell.Offset(0, 1).Activate
          Else
              ActiveCell.Offset(1, -1201).Activate
              ActiveCell.Value = ""
              ActiveCell.Offset(0, 1).Activate
          End If
      Else
          If mosheet.Cells(i, j).Value <> "999" Then
              ActiveCell.Value = mosheet.Cells(i, j).Value
              ActiveCell.Offset(0, 1).Activate
          Else
              ActiveCell.Value = ""
              ActiveCell.Offset(0, 1).Activate
          End If
      End If
      
      元々のコードに関して、比較の順序の観点からは、
      ActiveCell.Offset(0, 1).Value = "" のほうが圧倒的に多いにもかかわらず、
      ActiveCell.Offset(0, 1).Value <> "" かどうか、しかも同時に
      mosheet.Cells(i, j).Value <> "999" の不要な判定を逐一実行することになっています。
      
      ですから、その意味からは、
      ActiveCell.Offset(0, 1).Value = ""といったTrueになる条件を
      前にもってきたほうが有利になるでしょう。
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191707] Re[10]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ みらくる -(2020/04/08(22:31))
    □U R L/
      γ様
      興味のあるコメントでしたので処理時間タイマーを確認してみました。
      最初の私のコード(AND使用)は300秒で5分でしたが、以下2つのコード
      (AND未使用、IFのネスト)は≒4分で2割短縮できました。
      
      次のコードは250秒程度で≒4分でした。
      (繰返し内コード抜粋)
      
                  If mosheet.Cells(i, j).Value = "" Then
                      Exit Do
                  End If
        
            If ActiveCell.Offset(0, 1).Value <> "" Then
                      If mosheet.Cells(i, j).Value <> "999" Then
                          ActiveCell.Offset(1, -1201).Activate
                          ActiveCell.Value = mosheet.Cells(i, j).Value
                          ActiveCell.Offset(0, 1).Activate
                      Else
                          ActiveCell.Offset(1, -1201).Activate
                          ActiveCell.Value = ""
                          ActiveCell.Offset(0, 1).Activate
                      End If
                  Else
                      If mosheet.Cells(i, j).Value <> "999" Then
                          ActiveCell.Value = mosheet.Cells(i, j).Value
                          ActiveCell.Offset(0, 1).Activate
                      Else
                          ActiveCell.Value = ""
                          ActiveCell.Offset(0, 1).Activate
                      End If
                  End If
      
      次のコードも250秒程度で≒4分でした。
      (繰返し内コード抜粋)
      
                  If mosheet.Cells(i, j).Value = "" Then
                      Exit Do
                  End If
        
                  If ActiveCell.Offset(0, 1).Value = "" Then
                      If mosheet.Cells(i, j).Value <> "999" Then
                          ActiveCell.Value = mosheet.Cells(i, j).Value
                          ActiveCell.Offset(0, 1).Activate
                      Else
                          ActiveCell.Value = ""
                          ActiveCell.Offset(0, 1).Activate
                      End If
                  Else
                      If mosheet.Cells(i, j).Value <> "999" Then
                          ActiveCell.Offset(1, -1201).Activate
                          ActiveCell.Value = mosheet.Cells(i, j).Value
                          ActiveCell.Offset(0, 1).Activate
                      Else
                          ActiveCell.Offset(1, -1201).Activate
                          ActiveCell.Value = ""
                          ActiveCell.Offset(0, 1).Activate
                      End If
                  End If


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191708] Re[11]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ γ -(2020/04/08(22:50))
    □U R L/

      最後の比較は意味がありません。
      「元々のコードに関して」と明記しています。




    [191709] Re[12]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ まっつわん -(2020/04/09(13:18))
    □U R L/
      気分転換に。。。
      これでも一応結果は同じなのかな。。。
      
      Sub test002()
          Dim rngFrom As Range: Set rngFrom = Worksheets(3).Range("B2:AC77444")
          Dim rngTo As Range: Set rngTo = Worksheets(1).Range("D6:ATH1806")
          Dim c As Range
          Dim ix As Range
          
          rngTo.ClearContents
      
          For Each c In rngFrom
              ix = ix + 1
      
              Select Case c
                  Case 999, Empty
                  Case Else
                      rngTo(ix) = c
              End Select
          Next
      End Sub


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191710] Re[13]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ みらくる -(2020/04/09(21:23))
    □U R L/
      γ様
      
      >ActiveCell.Offset(0, 1).Value = ""といったTrueになる条件を
      >前にもってきたほうが有利になるでしょう。
      >「元々のコードに関して」と明記しています。
      
      失礼しました。元々のコードを以下に変更してタイマーを確認しましたら280秒で
      少し短縮されました。
      
                  ElseIf ActiveCell.Offset(0, 1).Value = "" And mosheet.Cells(i, j).Value <> "999" Then
                  ActiveCell.Value = mosheet.Cells(i, j).Value
                  ActiveCell.Offset(0, 1).Activate
                    
                  ElseIf ActiveCell.Offset(0, 1).Value = "" And mosheet.Cells(i, j).Value = "999" Then
                  ActiveCell.Value = ""
                  ActiveCell.Offset(0, 1).Activate
      
                  ElseIf mosheet.Cells(i, j).Value <> "999" Then
                  ActiveCell.Offset(1, -1201).Activate
                  ActiveCell.Value = mosheet.Cells(i, j).Value
                  ActiveCell.Offset(0, 1).Activate
                  
                  ElseIf mosheet.Cells(i, j).Value = "999" Then
                  ActiveCell.Offset(1, -1201).Activate
                  ActiveCell.Value = ""
                  ActiveCell.Offset(0, 1).Activate
      
      まっつわん様
      
      まっつわん様のコードを実行しましたら、次のエラーのダイアログが出ました。
      「オブジェクト変数またはWITHブロック変数が設定されていません」
      デバッグを押したら、「ix = ix + 1」が黄色くなりました。
      対処方法を教えていただけますでしょうか?


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191711] Re[14]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ まっつわん -(2020/04/09(21:32))
    □U R L/
      Dim ix As RangeDim ix As Long
      
      の間違いですね。すみません。^^;


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191712] Re[15]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ みらくる -(2020/04/09(21:54))
    □U R L/
      まっつわん様
      
      Dim ix As Longに変更して、まっつわん様のコードを実行しましたら12秒で転記が
      完了しました。コードはかなりシンプルですが、自分には分かりませんので解説
      お願いしたいのですがよろしいでしょうか。


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191713] Re[16]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ まっつわん -(2020/04/09(23:27))
    □U R L/
      12秒?????
      
      そんな劇的に速くなります?
      なんかの間違いじゃないですかね?
      
      とりあえず、、、、
      
      Set wsS = Worksheets(3)            '転記元シート
      
      「WorkSheets」というのは、ワークシートの集まりを示します。
      例えばSheet1、Sheet2、Sheet3とブックに存在するとしたら、
      これら全部を指示します。
      で、(3)というのはその集まりのうちの3番目という意味です。
      
      セル範囲も同じ考えで、
      Range("A1:A10")というセル範囲を示したとき、
      A1、A2、A3・・・・・A10と10個のセルの集まりと考えられます。
      
      ということは、
      Range("A1:A10")(5).Select
      と命令したら、A5セルが選択できるということです。
      ならば、
      Range("A1:C3")(5).Select
      としたら、どのセルが選択できるでしょうか?
      (試してみてください。)
      
      こういう何かの集まりを「コレクション(Collection)」と呼びます。
      このコレクションを順に見て行くときは、
      For Each  〜 Next のステートメントを使います。
      
      Sub test1()
          Dim r As Range
          Dim i As Long
          
          Set r = Range("A1:E5")
          For i = 1 To r.Count
              r(i).Select
          Next
      End Sub
      
      Sub test2()
          Dim r As Range
          Dim c As Range
          
          For Each c In r
              c.Select
          Next
      End Sub
      
      上記2つのプロシージャをそれぞれステップインで1行づつ実行してみて、
      どのセルが選択されるか確認してみてください。
      同じ挙動をすると思います。
      
      つまり、セルの集まりにも、それぞれ番号で示せることが確認出来ると思います。
      ならば、セル範囲の形が違っても、左上から横優先で数えた番号が同じなら、
      
          For Each c In rngFrom
              ix = ix + 1
          rngTo(ix) = c
      
      こういった位置関係が成立するかなと思った次第です。
      
      しかし、ホントに期待した結果が得られて12秒です?
      個人的に大きなデータを扱うことがないので、
      高速化はあんまり気にしてないので、わからないのです^^;
      For 〜 Next より For Each 〜 Next
      の方が速いという噂は聞いたことがありますが、
      どこでそんなに違うんでしょう。。。。(研究する元気はないのですが^^;)
      とにかくSelectやActivateをしないのは基本中の基本ですが、
      12秒で終わるなら、ぎりぎり使えるっていえば使えますけど、
      頻繁にそういうことをするなら、出来れば2秒以内に終わらせたいですねー
      (出来るかできないか解りませんが。。。。)
      でも、γさんの配列変数を使ったサンプルで7秒なのに
      セルを読み書きして12秒は何か抜けてる気がします。
      配列変数を使った方が百倍くらいは速い気がするので。。。。
      
      ちなみに、
      結果が合っているとして、、、、、
      
      >        Select Case c
      >            Case 999, Empty
      >            Case Else
      >                rngTo(ix) = c
      >        End Select
      
              Select Case c.value
                  Case 999, Empty
                  Case Else
                      rngTo(ix).value = c.value
              End Select
      
      とValueプロパティを明示したら何秒くらいになります?
      同じく、
      ValueをCellsに変えたら何秒になります?
      
      ほんとに12秒で終わるのかなあ。。。。。。
      ちょっと実験してみよー


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191714] Re[17]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ まっつわん -(2020/04/09(23:58))
    □U R L/

      やっぱ、2分以上かかりますね。

      最初に提示したコードはなんかおかしな結果を返しますね^^;
      デバッグする元気がないのでこれにて^^;




    [191715] Re[18]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ γ -(2020/04/10(07:21))
    □U R L/
      Rangeオブジェクトの引数の個数1のItemプロパティを使った例は興味深いですね。
      セルがEmptyの時だけスキップするようにすれば正しい答えが出ると思われます。
      やはり一セルずつ書き込みしていますので、それなりに時間はかかると思います。
      
      
      さて、質問者さんに、もうひとつ情報提供しておきましょう。
      実は私も同様の発想で一次元配列を経由した転記を試していました。
      期待していた効率化が図れなかったので、お蔵入りしていました。
      
      ここでは、それらの実行時間の内訳を見てもらって、
      少しばかりのインプリケーションに触れておきましょう。
      
      (イミディエイトウインドウへの出力)
       0.890625  設定まで                
       2.357422  転記@
       0.195312  転記A
       3.792969  ワークシート記入
       7.240234  計:配列利用その2
      となりました。
      
      (1)シートから配列を作るところは     0.89秒
      (2)配列から一次元配列への転記は     2.35秒
      (3)一次元配列から最終配列への転記は 0.19秒
      (4)配列のシートへの書き込みは       3.79秒 計7.2秒
      という感じです。(2)がもっと早くて良い気もしますが、結構かかっています。
      
      一つずつセルに書き込むのに比べて、配列を利用した一括書き込みは
      とても効果がありますが、それでもこの部分に3.8秒程度かかっており、
      ここはこれ以上の速度アップは望めないので、高速化といっても、
      3.8秒程度が限界ということなのでしょう。
      
      配列利用の効果については、読み込み部分よりもやはり一括書き込みの効果が大きい印象があります。
      参考にして下さい。
      
      -------------------------------
      Sub 値転記Ver3()    '配列利用その2 思ったほど早くならなかった。
          Dim wsS  As Worksheet
          Dim wsD  As Worksheet
          Dim i    As Long
          Dim j    As Long
          Dim k    As Long
          Dim matS As Variant
          Dim matD As Variant
          
          Dim t, t0
          t = Timer
          t0 = t
          
          Set wsS = Worksheets(3)            '転記元シート
          Set wsD = Worksheets("転記先")     '転記先シート
      
          wsD.Range("D6:ATH1806").ClearContents  '前回の転記先データの一括クリア
      
          matS = wsS.Range("B2:AC77444").Value
          matD = wsD.Range("D6:ATH1806").Value
          
          ReDim mat(1 To UBound(matD, 1) * UBound(matD, 2))
          
          Debug.Print Timer - t; " 設定まで" '------------------------------------
          t = Timer
          
          '一次元の配列にいったん転記
          k = 1
          For i = 1 To UBound(matS, 1)
              For j = 1 To UBound(matS, 2)
                  If matS(i, j) <> "" Then
                      If matS(i, j) <> "999" Then
                          mat(k) = matS(i, j)
                      End If
                      k = k + 1
                  End If
              Next
          Next
          
          Debug.Print Timer - t; " 転記@"    '------------------------------------
          t = Timer
          
          '別の2次元配列に転記
          k = 1
          For i = 1 To UBound(matD, 1)
              For j = 1 To UBound(matD, 2)
                  matD(i, j) = mat(k)
                  k = k + 1
              Next
          Next
          
          Debug.Print Timer - t; " 転記A"    '------------------------------------
          t = Timer
          
          'ワークシートに転記
          wsD.Range("D6").Resize(UBound(matD, 1), UBound(matD, 2)).Value = matD
      
          Debug.Print Timer - t; " ワークシート記入"      '------------------------------------
          
          Debug.Print Timer - t0; " 計:配列利用その2"  '------------------------------------
      End Sub
      
      
      (以下、余談です。)
      
      配列を含む数値計算に関して速度を重視するなら、
      Excelにはやはり限度があります。
      これにこだわらず、別の道具も検討したほうがよいでしょう。
      理系の若い人であれば、RとかPythonとかMATLABなどご存じかも知れません。
      Rは統計処理に関する情報が早く反映され、可視化に強いことから人気があります。
      速度は余り期待できないかもしれませんが。
      また、Pythonは昨今データサイエンスの場面でよく使われます。
      
      このほか、私はJuliaという言語を推したいと思います。
      これはMITの関係者が開発運営を行っている言語です。
      Cの速度と、PythonやRubyのような動的さを兼ね備えた言語と言われています。
      今回の例について、試してみたところ、
      サンプルデータの作成から配列変換部分全てを実行しても、0.1秒程度で実現出来ます。
      かなり高速に動作します。
      
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191716] Re[19]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ まっつわん -(2020/04/10(08:22))
    □U R L/

      γさんのサンプルを動作確認してみたいけど、
      いまさらだけど。。。。

      > '転記元シートの転記範囲:B2〜AC77444(サイズ77443行×28列)
      > '転記元シートのデータは43行毎(1ブロック)に最後に空欄セルが3つあり(AA〜AC列)
      > '転記元シートのデータ数=77443×28-(77443÷43)×3=2163001セル

      これの意味がどうしてもわからない^^;

      あれ?
      もとの43行分を1行にしたいということなのかな。。。。
      43行ごとに3行空白行があるとずっと思ってた。。。。^^;

      なら。コードを直さないと。。。。




    [191717] Re[20]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ まっつわん -(2020/04/10(19:20))
    □U R L/
      一応、直しました。
      
      Sub test002()
          Dim rngFrom As Range: Set rngFrom = Worksheets(3).Range("B2:AC77444")
          Dim rngTo As Range: Set rngTo = Worksheets("転記先").Range("D6:ATH1806")
          Dim c As Range
          Dim ix As Long
          Dim t
      
          t = Timer
      
          rngTo.ClearContents
      
          For Each c In rngFrom
              If IsEmpty(c) = False Then
                  ix = ix + 1
                  If c < 999 Then rngTo(ix) = c
              End If
          Next
      
          Debug.Print Timer - t & "秒"
      End Sub
      
      こちらの環境で約144秒
      
      Sub test003()
          Dim t
          t = Timer
      
          Dim vrtFrom As Variant: Let vrtFrom = Worksheets(3).Range("B2:AC77444")
          Dim rngTo As Range:     Set rngTo = Worksheets("転記先").Range("D6:ATH1806")
          Dim vv()
          Dim ixH As Long, ixV As Long
          Dim x As Long, y As Long, m As Long
          Dim d As Double
      
          rngTo.ClearContents
          ReDim vv(1 To rngTo.Rows.Count, 1 To rngTo.Columns.Count)
          m = UBound(vv, 2)
      
          ixV = 1
          For x = LBound(vrtFrom, 1) To UBound(vrtFrom, 1)
              For y = LBound(vrtFrom, 2) To UBound(vrtFrom, 2)
                  d = vrtFrom(x, y)
                  If d > 0 Then
                      ixH = ixH + 1
                      If ixH > m Then
                          ixH = 1
                          ixV = ixV + 1
                      End If
      
                      If d < 999 Then vv(ixV, ixH) = d
                  End If
              Next
          Next
      
          rngTo = vv
          Debug.Print Timer - t & "秒"
      End Sub
      
      これだと約4秒
      γさんの値転記Ver3は約6秒
      
      おまけ、
      Sub test004()
          Dim rngFrom As Range
          Dim rngTo As Range
          Dim rngCopy As Range
          Dim ix As Long
          Dim m As Long
          Dim s As Long
          Const n As Long = 43
          
          Dim t
          t = Timer
      
          'Application.ScreenUpdating = False
          
          Set rngFrom = Worksheets(3).Range("B2:AC77444")
          Set rngTo = Worksheets("転記先").Range("D6:ATH1806")
          rngTo.Worksheet.UsedRange.ClearContents
          
          With rngFrom.Rows
              Set rngCopy = .Item(1)
              For ix = 1 To .Count Step n
                  Set rngCopy = Union(rngCopy, .Item(ix))
              Next
          End With
          
          m = rngFrom.Columns.Count
          s = 1
          For ix = 1 To n
              rngCopy.Offset(ix - 1).Copy rngTo(1, s)
              s = s + m
          Next
          rngTo.Replace 999, ""
      
          'Application.ScreenUpdating = True
          Debug.Print Timer - t & "秒"
      End Sub
      
      約8秒でした。
      
      多分、列数、行数、値の個数、上行の先頭の値が同じなので、
      大丈夫かなと。


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191718] Re[21]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ γ -(2020/04/10(21:33))
    □U R L/
      お疲れ様です。
      
      そうですね、高速化の手段として、高性能マシンを使うという
      基本的な手段がありました。
      
      私のサブマシンの結果も示しておきましょう。ご参考まで。
      
      ●最初の配列利用について。
       3.328125    配列利用		
       3.296875    配列利用		
      
      ●配列利用その2というやつ。
       0.59375  設定まで		
       1.101563  転記@		
       0.109375  転記A		
       1.640625  ワークシート記入		
       3.460938  計:配列利用その2		
      		
       0.5546875  設定まで		
       1.171875  転記@		
       0.09375  転記A		
       1.625  ワークシート記入		
       3.445313  計:配列利用その2		
      (あれ、遅くなっているんですな。残念。)




    [191719] Re[22]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ みらくる -(2020/04/10(23:03))
    □U R L/

      まっつわん様

      色々試していただきまして誠にありがとうございました。
      また、詳細なコードのご説明ありがとうございました。
      なかなか理解するのは難しいですが頑張りたいと思います。

      転記元のデータは、43行目の後に3行の空白行があるのでなく、43行毎に
      43番目の行に右から3つのセルが空白ということです。
      転記先は43行毎のデータが、1行分です。
      (転記元43行×28列-3=転記先1201列)

      まっつわん様の後で示したコードを私も試し、以下全例の時間を確認しました。
      (イベントでブックオープン時に計算方法手動とした場合の時間です)
      TEST002・・12秒
      TEST003・・3秒
      TEST004・・50秒

      転記結果の検証
      以下@Aについて、転記先全セルの位置と値について、私の最初のコード結果と
      IF関数を使い作業シートで同じか比較したところ全て一致しました。

      @γ様配列(最初のコード)(2回目の配列はまだ試していません)
      Aまっつわん様TEST002(新)とTEST003

      まっつわん様TEST004は一致しない部分がありました。
      こちらの手違いならすみません。

      γ様

      興味深い情報ありがとうございました。
      2次元の配列、時間のある時に理解できるよう努めたいと思います。

      参考としまして、今回のデータは、国土地理院のHPで公開しているジオイドモデル
      データ(重力データ)です。元はテキストファイルです。
      実務のコードは、転記前にテキスト読込も含みます。

      測量ではジオイドが必要になります。GPS(GNSS)測量では楕円体高が求まります
      が、私たちが身近に使うのは標高です。楕円体高-ジオイド高=標高です。

      ジオイドは2KMメッシュで日本全体を囲んでいますので莫大なデータになります。
      私的には転記作業は、ジオイドが地理院で更新されたときに必要になります。
      数年に1回の作業なので、ごくたまにの作業ですが、速い方がいいと思いまして
      質問した次第です。









    [191720] Re[23]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ まっつわん -(2020/04/10(23:45))
    □U R L/

      >参考としまして、今回のデータは、国土地理院のHPで公開しているジオイドモデル
      データ(重力データ)です。元はテキストファイルです。
      >実務のコードは、転記前にテキスト読込も含みます。

      あ〜れ〜
      最初にサンプルデータとしてそれのアドレスを示してくれたら、
      それで、動作確認できたのにー><

      こちら、測量試補、一応合格証もってるし、
      日常、レベルや光波測距儀で測量してるので(楕円体補正をするような測量はしませんが)、
      無関係な話でもなかったのに。。。
      「数年に1回」ありがちですね^^;
      °’"の表示、数年に1回エクセルで使いたくなるけど、
      すぐやり方忘れてしまいます><
      ま、またなにか縁がありましたら、よろしくお願いしますです。
      ここのサイトあんまり見てないので、話しに参加できるかわかりませんが。




    [191723] Re[24]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ みらくる -(2020/04/11(08:32))
    □U R L/

      まっつわん様

      >最初にサンプルデータとしてそれのアドレスを示してくれたら、
      >それで、動作確認できたのにー><

      失礼しました。お手間を取らせ申し訳ございません。

      >日常、レベルや光波測距儀で測量してるので(楕円体補正をするような測量はしませんが)

      私もレベルや光波測距儀だけで測量し、GPS(GNSS)測量機はないので使っていま
      せんが、趣味で測量ソフト全般を作っています。
      参考に「楽らく測量」で検索すると出てきます。




    [191724] Re[25]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ まっつわん -(2020/04/11(10:57))
    □U R L/

       >参考に「楽らく測量」で検索すると出てきます。

      おおおおおおおおおおお!!!!!!!
      ありがたや!

      需要があるかわかりませんが、
      任意に3次元測量をし、
      ドロネー三角形分割をして、
      面積&土量計算ができるソフトを開発していただけると助かりますが。。。
      (依頼ではなくただの妄想です)
      アルゴリズムがいまいち理解できなくて、断念しました。

      今、宅地造成してるんで、ヤマ勘で無く概略で不足&残土の土量がつかめると
      ありがたいんですがねー。。。

      あとで、「楽らく測量」ダウンロードしてみます。
      2万未満なら個人で購入するんで、いろいろ充実していただければ、
      購入の検討が出来ると思うんですが。。。。
      今使っているソフトが、開発終了してしまったので^^;
      やっぱ、商品として売るとなるとなかなかサポートが大変なのでしょうか。。。。





    [191725] Re[26]: 値転記の時間短縮-

    記事引用/メール受信=OFF■

    □投稿者/ みらくる -(2020/04/11(11:53))
    □U R L/

      まっつわん様

      >任意に3次元測量をし、
      >ドロネー三角形分割をして、
      >面積&土量計算ができるソフトを開発していただけると助かりますが

      私はどんな計算もマクロは一切しようぜず(ユーザー定義関数がわからないため)
      シートを必要数作成し数式と関数で結果を求めます。そのため容量が大きくなった
      ファイルは、時間もかかるため、イベントでブックオープン時計算方法手動にし、
      マクロボタンで計算実行(再計算)させています。

      そのため私の方法の計算部分はVBAとは関係ないので、この掲示板ではよろしく
      ないので、自作の楽らく測量!基準点セット等のフリーソフトのベクター等の
      頁から私のHPに入っていただきまして、メールで計算書一式を送っていただけ
      ますと助かります。その上で自分が可能かどうか判断したいと思います。
      計算式もわかればぜひ教えてください。

      よろしくお願いいたします。



このトピック内容の全ページ数 / [0]

このトピックに書きこむ
Name/
E-Mail/

└>このツリーのレス記事をメールで受信しますか? YES/ NO/
Title/
URL/
Comment/ 通常モード->  図表モード-> (←の場合適当に改行を入れて下さい)
タグが使用できます。例 ⇒ <font color="blue">文字</font>
解決!!ありがとうございました! 解決       保留中です・・・ 保留        迷宮入りorほかあたって見ます・・ 迷宮入       すいませ〜ん。誰か〜! Help! ←※回答者専用
解決したらチェック       保留(コードテスト中など・・)         解決不可orレスが全く付かなくてほかのサイトに行くときなど・・
削除キー/
(半角8文字以内) 


- Child Forum -
Edit:ゆう-G