Excel VBA質問箱 IV

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

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


56348 / 76737 ←次へ | 前へ→

【25145】Re:検索→削除
回答  ちゃっぴ  - 05/5/22(日) 13:13 -

引用なし
パスワード
   配列でゴリゴリ・・・

Const WORD_START_ROW As Long = 2&
Const TARGET_START_ROW As Long = 5&

Sub S_Main()
  Dim rngDataArea As Excel.Range
  Dim vntIndex  As Variant
  Dim vntData   As Variant
  Dim vntUpdate  As Variant

  ' Dataを配列に格納
  With Worksheets("ワード").Cells(WORD_START_ROW, 1)
    With .Resize(.Offset(65536 - WORD_START_ROW).End(xlUp).Row - WORD_START_ROW + 1)
      .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    End With
    vntIndex = .Resize(.End(xlDown).Row - WORD_START_ROW + 1).Value
  End With
  
  With Worksheets("sheet1").Cells(TARGET_START_ROW, 1)
    Set rngDataArea = .Resize( _
      .Offset(65536 - TARGET_START_ROW).End(xlUp).Row _
      - TARGET_START_ROW + 1, 5)
  End With
  vntData = rngDataArea.Value
  
  ' Matching
  vntUpdate = F_strEraseMatchData(vntData, vntIndex)
  
  rngDataArea.Value = vntUpdate
  
  'Call S_CopySheet(Worksheets("sheet1"))
End Sub


Function F_strEraseMatchData( _
  vntOriginal As Variant, _
  vntIndex As Variant) As String()
  
  Dim strUpdate() As String
  Dim vntBuf   As Variant
  Dim lngRows   As Long
  Dim lngColumns As Long
  Dim i      As Long
  Dim j      As Long
  Dim k      As Long
  
  lngRows = UBound(vntOriginal, 1)
  lngColumns = UBound(vntOriginal, 2)
  
  ReDim strUpdate(1 To lngRows, 1 To lngColumns)
  
  For i = 1 To lngRows
    For Each vntBuf In vntIndex
      If InStr(1, vntOriginal(i, 2), _
        vntBuf, vbTextCompare) > 0 Then
        
        j = j + 1
        For k = 1 To lngColumns
          strUpdate(j, k) = vntOriginal(i, k)
        Next k
        Exit For
      End If
    Next
  Next i
  
  F_strEraseMatchData = strUpdate
End Function

Sub S_CopySheet(wstTarget As Worksheet)
  Dim strShtName As String
  
  wstTarget.Copy After:=Worksheets(3)
  
  Do
    strShtName = Application.InputBox( _
      "シート名を入力して下さい。", "シート名入力", Type:=2)
    
    If strShtName = "False" Then
      MsgBox "キャンセルしました。"
      Worksheets(4).Delete
      Exit Sub
    End If
    
    On Error Resume Next
    Worksheets(4).Name = strShtName
    If Err.Number <> 0 Then
      MsgBox "同名のSheetが存在するか、使用不可能な文字が含まれています。" & vbLf _
        & "'" & shtName & "'"
    Else
      On Error GoTo 0
      Exit Do
    End If
  Loop
  
  MsgBox "完了"
End Sub

0 hits

【25090】検索→削除 いづみ 05/5/19(木) 21:46 質問
【25114】Re:検索→削除 ponpon 05/5/20(金) 14:45 回答
【25136】Re:検索→削除 いづみ 05/5/21(土) 0:03 質問
【25137】Re:検索→削除 ponpon 05/5/21(土) 13:07 回答
【25138】Re:検索→削除 kobasan 05/5/21(土) 15:17 発言
【25141】Re:検索→削除 ponpon 05/5/21(土) 21:42 発言
【25145】Re:検索→削除 ちゃっぴ 05/5/22(日) 13:13 回答
【25146】Re:検索→削除 いづみ 05/5/22(日) 15:00 質問
【25151】Re:検索→削除 ちゃっぴ 05/5/22(日) 22:13 回答

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