| |
>ちゃっぴさんのを試してみたらデータは
>うまく取り出せるのですが、メッセージＢＯＸが
>でてきませんでした。
その部分を Comment Out していたからです。
# もっともMissがあったので動きませんが･･･
>かなり難しすぎてぜんぜん分かりません(>_<)
>Function というのも初めてです。
Functionは基本なのでこの際きちんと理解しましょう。
簡単に言うと、Sub は値を返しませんが、
Functionは値を返します。
最近、まともなのかいてなかったので･･･
Class をつかわないでやるんでしたら、こんな感じで私はやりますね。
Private Const WORDS_SHEET_NAME As String = "ワード"
Private Const WORDS_START_ROW As Long = 2&
Private Const WORDS_START_COL As Long = 1&
Private Const WORDS_END_COL As Long = 1&
Private Const DATA_SHEET_NAME As String = "sheet1"
Private Const DATA_START_ROW As Long = 5&
Private Const DATA_START_COL As Long = 1&
Private Const DATA_END_COL As Long = 5&
Public Sub S_Main()
Dim wstDataSheet As Excel.Worksheet
Dim wstCopiedSheet As Excel.Worksheet
Dim rngDataArea As Excel.Range
Dim vntWordsList As Variant
Dim vntData As Variant
Dim vntUpdate As Variant
' Dataを配列に格納
Set wstDataSheet = Worksheets(DATA_SHEET_NAME)
Set rngDataArea = F_rngGetDataArea(wstDataSheet, _
DATA_START_ROW, DATA_START_COL, DATA_END_COL)
If rngDataArea Is Nothing Then
MsgBox "Dataが存在しません。", vbCritical
GoTo L_Ending
End If
vntData = rngDataArea.Value
' SheetのCopy
Set wstCopiedSheet = F_wstCopySheet(wstDataSheet, Worksheets(3))
If wstCopiedSheet Is Nothing Then GoTo L_Ending
' Words List を作成
vntWordsList = F_vntMakeWordsList( _
F_rngGetDataArea(Worksheets(WORDS_SHEET_NAME), _
WORDS_START_ROW, WORDS_START_COL, WORDS_END_COL))
' Matching
vntUpdate = F_strEraseMatchData(vntData, vntWordsList)
' Copy Sheet に Data出力
wstCopiedSheet.Cells(DATA_START_ROW, DATA_START_COL) _
.Resize(UBound(vntUpdate, 1), UBound(vntUpdate, 2)).Value _
= vntUpdate
' Sheet Data の消去
rngDataArea.ClearContents
MsgBox "処理が完了しました", vbInformation
L_Ending:
Set wstDataSheet = Nothing
Set wstCopiedSheet = Nothing
Set rngDataArea = Nothing
End Sub
' WordsList(配列:1次元)を作成
Private Function F_vntMakeWordsList(rngTarget As Excel.Range) As Variant
Dim dicList As Scripting.Dictionary
Dim vntList As Variant
Dim vntbuf As Variant
If rngTarget Is Nothing Then
vntList = Array("")
Else
' 重複を削除
Set dicList = New Scripting.Dictionary
For Each vntbuf In rngTarget.Value
dicList.Item(vntbuf) = ""
Next
vntList = dicList.Keys
Set dicList = Nothing
End If
' Return
F_vntMakeWordsList = vntList
End Function
' Data範囲を取得
Private Function F_rngGetDataArea( _
ByVal wstTarget As Excel.Worksheet, _
ByVal lngStartRow As Long, _
ByVal lngStartCol As Long, _
ByVal lngEndCol As Long) As Excel.Range
Dim rngStart As Excel.Range
Dim rngEnd As Excel.Range
Dim lngColOffset As Long
lngColOffset = lngEndCol - lngStartCol
With wstTarget
Set rngStart = .Cells(lngStartRow, lngStartCol)
Set rngEnd = .Cells(.Rows.Count, lngStartCol)
End With
If rngStart.Value = "" Then GoTo L_Ending
If rngEnd.Value = "" Then
Set rngEnd = rngEnd.End(xlUp).Offset(, lngColOffset)
Else
Set rngEnd = rngEnd.Offset(, lngColOffset)
End If
Set F_rngGetDataArea _
= wstTarget.Range(rngStart, rngEnd)
L_Ending:
Set rngStart = Nothing
Set rngEnd = Nothing
End Function
' Matchingし、有効なDataのみを返す
Private 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
' SheetのCopy & Rename
Private Function F_wstCopySheet( _
ByVal wstTarget As Excel.Worksheet, _
ByVal wstAfterDestination As Excel.Worksheet _
) As Excel.Worksheet
Dim wstCopiedSheet As Excel.Worksheet
Dim strShtName As String
wstTarget.Copy After:=wstAfterDestination
Set wstCopiedSheet = Worksheets(wstAfterDestination.Index + 1)
Do
strShtName = Application.InputBox( _
"シート名を入力して下さい。", "シート名入力", Type:=2)
If strShtName = "False" Then
Application.DisplayAlerts = False
wstCopiedSheet.Delete
Application.DisplayAlerts = True
Set wstCopiedSheet = Nothing
Exit Function
End If
On Error Resume Next
wstCopiedSheet.Name = strShtName
If Err.Number <> 0 Then
MsgBox "同名のSheetが存在するか、使用不可能な文字が含まれています。" & vbLf _
& "'" & strShtName & "'", vbExclamation
Else
On Error GoTo 0
Exit Do
End If
Loop
Set F_wstCopySheet = wstCopiedSheet
Set wstCopiedSheet = Nothing
End Function
そんなに難しいことはやっていないので、
がんばって理解してください。
|
|
ちゃっぴ
- 05/5/22(日) 22:13 -
