|
配列でゴリゴリ・・・
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
|
|