Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


4143 / 13644 ツリー ←次へ | 前へ→

【58131】数値データのみ抽出 まさと 08/10/5(日) 14:31 質問[未読]
【58132】Re:数値データのみ抽出 カウボーイズ 08/10/5(日) 15:08 回答[未読]
【58133】Re:数値データのみ抽出 Hirofumi 08/10/5(日) 17:35 回答[未読]
【58134】Re:数値データのみ抽出 Hirofumi 08/10/5(日) 18:24 発言[未読]
【58135】Re:数値データのみ抽出 Hirofumi 08/10/5(日) 18:41 回答[未読]
【58136】Re:数値データのみ抽出 まさと 08/10/5(日) 19:12 お礼[未読]
【58139】Re:数値データのみ抽出 まさと 08/10/6(月) 0:12 質問[未読]
【58156】Re:数値データのみ抽出 Hirofumi 08/10/6(月) 18:52 回答[未読]
【58157】Re:数値データのみ抽出 Hirofumi 08/10/6(月) 18:56 回答[未読]
【58222】Re:数値データのみ抽出 まさと 08/10/12(日) 12:46 お礼[未読]

【58131】数値データのみ抽出
質問  まさと  - 08/10/5(日) 14:31 -

引用なし
パスワード
   お世話になります。
以下の例のように、数値のブロックと文字のブロックのデータがあるのですが、現在数値以外を片っ端から消去して、数値だけ残した状態で他のシートに飛ばしているといった現状です。現在私の使っているコードは以下の通りで、数値だけを抽出しています。
ここで質問なのですが、この処理では若干速度が遅く、使い物にならない状態でして、これより高速に数値だけのブロックを他のシートに移動させたいのですが
。結果させ、伴っていたら方法は選ばないので方法論としてご存知の方がいましたらどうぞアドバイスお願いします。

Dim mymax,i as variant
mymax = Worksheets("テスト").RANGE("A65536").End(xlUp).row
For i = mymax To 1 Step -1
 If IsNumeric(Sheets("テスト").Cells(i, 2)) = False Or Cells(i, 2) = "" Then
    Rows(i).Select
    Selection.Delete Shift:=xlUp
 End If
Next

////////////例/////////////////////////
(シート1)
11111111111111
11111111111111

あああああああ

22222222222222
  ↓
(シート2)
11111111111111
11111111111111
22222222222222

【58132】Re:数値データのみ抽出
回答  カウボーイズ  - 08/10/5(日) 15:08 -

引用なし
パスワード
   こんにちは
データがどれくらいあるのかわかりませんが、
画面更新の停止と不必要な Select 処理を排除してみてはどうでしょうか?

画面更新の停止
Application.ScreenUpdating = False

>Rows(i).Select
>Selection.Delete Shift:=xlUp
  ↓
Rows(i).Delete Shift:=xlUp

画面更新の再開
Application.ScreenUpdating = True

【58133】Re:数値データのみ抽出
回答  Hirofumi  - 08/10/5(日) 17:35 -

引用なし
パスワード
   先頭列が数値か文字列かを比較するだけで善いのなら

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim j As Long
  Dim lngCount As Long
  Dim lngRows As Long
  Dim lngColumns As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntData As Variant
  Dim lngDelete() As Long
  Dim strProm As String

  '結果を出力する位置すぉ指定
  Set rngResult = Worksheets("Sheet2").Cells(1, 1)
  
  With Worksheets("Sheet1").UsedRange
    '◆Listの先頭セル位置を基準とする
    Set rngList = .Cells(1, 1)
    '行列数の取得
    lngRows = .Rows.Count
    lngColumns = .Columns.Count
    If .Count = 1 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データ全てをSheet2にCopy
    .Copy Destination:=rngResult
    '削除Flag用の配列を確保
    ReDim lngDelete(lngRows - 1, 1 To 1)
  End With
  
  With rngResult
    '先頭列の値が文字列なら削除Flagに1を立てる
    For i = 0 To lngRows - 1
      '列データを配列に取得
      vntData = .Offset(i).Resize(, lngColumns + 1).Value
      '先頭列の値が空白で若しくは、数値で無いなら
      If vntData(1, 1) = "" Or (Not IsNumeric(vntData(1, 1))) Then
        'Flagに1を立てる
        lngDelete(i, 1) = 1
        '削除行数をカウント
        lngCount = lngCount + 1
      End If
    Next i
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngResult
    If lngCount > 0 Then
      'FlagをL列に出力
      .Offset(, lngColumns).Resize(lngRows) = lngDelete
      '削除行を最終行に集める為、L列をKeyとして整列
      .Resize(lngRows, lngColumns + 1).Sort _
          Key1:=.Offset(, lngColumns), Order1:=xlAscending, _
          Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
          Orientation:=xlTopToBottom, SortMethod:=xlStroke
      '行を削除
      .Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Delete
      'Keyを削除
      .Offset(, lngColumns).EntireColumn.Delete
    End If
  End With
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
     
End Sub

【58134】Re:数値データのみ抽出
発言  Hirofumi  - 08/10/5(日) 18:24 -

引用なし
パスワード
   あ!!、「画面更新の停止」をもっと前にした方が効果的だった


  '結果を出力する位置すぉ指定
  Set rngResult = Worksheets("Sheet2").Cells(1, 1)
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With Worksheets("Sheet1").UsedRange
    '◆Listの先頭セル位置を基準とする
    Set rngList = .Cells(1, 1)
  ・
  ・
  End With
  
  '画面更新を停止
'  Application.ScreenUpdating = False
  

それと、今回はデータの総数量が解らなかったので、1行づつ処理していますが
データ量が、差ほど大きく無いなら、全て配列で処理した方が因り速く成ります

【58135】Re:数値データのみ抽出
回答  Hirofumi  - 08/10/5(日) 18:41 -

引用なし
パスワード
   この方が速いかも?

Option Explicit

Public Sub Sample2()

  Dim i As Long
  Dim lngCount As Long
  Dim lngRows As Long
  Dim lngColumns As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntData As Variant
  Dim lngDelete() As Long
  Dim strProm As String

  '結果を出力する位置すぉ指定
  Set rngResult = Worksheets("Sheet2").Cells(1, 1)
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With Worksheets("Sheet1").UsedRange
    '◆Listの先頭セル位置を基準とする
    Set rngList = .Cells(1, 1)
    '行列数の取得
    lngRows = .Rows.Count
    lngColumns = .Columns.Count
    If .Count = 1 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データ全てをSheet2にCopy
    .Copy Destination:=rngResult
    '先頭列の値を配列に取得
    vntData = rngList.Resize(lngRows + 1).Value
    '削除Flag用の配列を確保
    ReDim lngDelete(1 To lngRows, 1 To 1)
  End With
  
  With rngResult
    '先頭列の値が文字列なら削除Flagに1を立てる
    For i = 1 To lngRows
      '先頭列の値が空白で若しくは、数値で無いなら
      If vntData(i, 1) = "" Or (Not IsNumeric(vntData(i, 1))) Then
        'Flagに1を立てる
        lngDelete(i, 1) = 1
        '削除行数をカウント
        lngCount = lngCount + 1
      End If
    Next i
  End With
  
  With rngResult
    If lngCount > 0 Then
      'FlagをL列に出力
      .Offset(, lngColumns).Resize(lngRows) = lngDelete
      '削除行を最終行に集める為、L列をKeyとして整列
      .Resize(lngRows, lngColumns + 1).Sort _
          Key1:=.Offset(, lngColumns), Order1:=xlAscending, _
          Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
          Orientation:=xlTopToBottom, SortMethod:=xlStroke
      '行を削除
      .Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Delete
      'Keyを削除
      .Offset(, lngColumns).EntireColumn.Delete
    End If
  End With
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
     
End Sub

【58136】Re:数値データのみ抽出
お礼  まさと  - 08/10/5(日) 19:12 -

引用なし
パスワード
   みなさん、ご回答真に感謝します。
内容を理解した上で現行のプログラムと移行したいので、
内容を理解して、実際動かして、改めてお礼又は、質問という形で投稿させてもいますので、よろしくお願いします。 本当にありがとうございます。

【58139】Re:数値データのみ抽出
質問  まさと  - 08/10/6(月) 0:12 -

引用なし
パスワード
   すいません、例が間違っていました。以下の用に行列変換して移動でした。
現在はシート1で数字だけにして、setで列を配列変数にセットして、Transposeで行列変換して移動している形でした。
サンプルコードを応用できるか考えて見ますが、現在完全に理解してない状態ですので、すぐに改良できましたら、よければですがよろしくお願いします。
ご迷惑おかけしました。

(シート1)
123456
123456
123456

あああ

123456

(シート2)
1111
2222
3333
4444
5555
6666

【58156】Re:数値データのみ抽出
回答  Hirofumi  - 08/10/6(月) 18:52 -

引用なし
パスワード
   >現在はシート1で数字だけにして、setで列を配列変数にセットして、
>Transposeで行列変換して移動している形でした。

では、シート1上でデータの削除を行って善いのですね?
こんなで如何でしょう

Option Explicit

Public Sub Sample3()

  Dim i As Long
  Dim lngCount As Long
  Dim lngRows As Long
  Dim lngColumns As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntData As Variant
  Dim lngDelete() As Long
  Dim strProm As String

  '結果を出力する位置すぉ指定
  Set rngResult = Worksheets("Sheet2").Cells(1, 1)
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With Worksheets("Sheet1").UsedRange
    '◆Listの先頭セル位置を基準とする
    Set rngList = .Cells(1, 1)
    '行列数の取得
    lngRows = .Rows.Count
    lngColumns = .Columns.Count
    If .Count = 1 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '先頭列の値を配列に取得
    vntData = rngList.Resize(lngRows + 1).Value
    '削除Flag用の配列を確保
    ReDim lngDelete(1 To lngRows, 1 To 1)
  End With
  
  With rngList
    '先頭列の値が文字列なら削除Flagに1を立てる
    For i = 1 To lngRows
      '先頭列の値が空白で若しくは、数値で無いなら
      If vntData(i, 1) = "" Or (Not IsNumeric(vntData(i, 1))) Then
        'Flagに1を立てる
        lngDelete(i, 1) = 1
        '削除行数をカウント
        lngCount = lngCount + 1
      End If
    Next i
    If lngCount > 0 Then
      'FlagをL列に出力
      .Offset(, lngColumns).Resize(lngRows) = lngDelete
      '削除行を最終行に集める為、L列をKeyとして整列
      .Resize(lngRows, lngColumns + 1).Sort _
          Key1:=.Offset(, lngColumns), Order1:=xlAscending, _
          Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
          Orientation:=xlTopToBottom, SortMethod:=xlStroke
      '行を削除
      .Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Delete
      'Keyを削除
      .Offset(, lngColumns).EntireColumn.Delete
    End If
  End With
  
  With rngResult
    If rngList.Resize(lngRows - lngCount, lngColumns).Count > 1 Then
      '削除処理を行ったデータをTransposeしてSheet2に貼り付け
      .Resize(lngColumns, lngRows - lngCount).Value _
          = Application.WorksheetFunction.Transpose(rngList.Resize(lngRows _
              - lngCount, lngColumns).Value)
    End If
  End With
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
     
End Sub

【58157】Re:数値データのみ抽出
回答  Hirofumi  - 08/10/6(月) 18:56 -

引用なし
パスワード
   以下の部分のIf分は要らなかった様です

  With rngResult
'    If rngList.Resize(lngRows - lngCount, lngColumns).Count > 1 Then '★削除
      '削除処理を行ったデータをTransposeしてSheet2に貼り付け
      .Resize(lngColumns, lngRows - lngCount).Value _
          = Application.WorksheetFunction.Transpose(rngList.Resize(lngRows _
              - lngCount, lngColumns).Value)
'    End If '★削除
  End With

【58222】Re:数値データのみ抽出
お礼  まさと  - 08/10/12(日) 12:46 -

引用なし
パスワード
   ご回答ありがとうございます。
ちょっと私的事情で立て込んでおりまして、PCを起動できませんでした。先ほど確認させてもらいました。現行の物と差し替えて動かしましたら、前のプログラムより確かに早いです!
いろいろ、ノウハウ所が満載のプログラムでとても勉強になりました。
本当に貴重な時間を割いていただき、すばらしいプログラムを教えていただいて感謝しております。ありがとうございまいした。

4143 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free