Excel VBA質問箱 IV

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

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


23952 / 76732 ←次へ | 前へ→

【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

4 hits

【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 お礼

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