0

私は以下にこのコードを持っていますが、これは私がやろうとしていることに非常に近いものです。仕組みは、Excelスプレッドシートの[単語の問題を一覧表示]ボタンを押すと、単語のリストを含む別のワークシートに対して、セルごと、列Aの行ごとにすべてのテキストをスキャンします。（列1の個々のセルにあるものの間に）一致する場合は、一致する単語を列bの隣接する行に配置します。

ここ（http://mintywhite.com/more/software-more/microsoft-excel-analyze-free-text-surveys-feedback-complaints-part-2）は、コードを見つけた記事へのリンクです。リンク（http://mintywhite.com/wp-content/uploads/2011/02/wordcount2.xls）を使用して、.xlsスプレッドシート全体をダウンロードします。

私が探しているのは単純な変更なので、最初のワークシートの列Aの各セル/行に単語が少なくとも5回表示されない限り、「一致」はありません。

    Sub WordCount()

    Dim vArray, WordIssue, ElementCounter As Variant
    Dim lngLoop, lngLastRow As Long
    Dim rngCell, rngStoplist As Range

    ElementCounter = 2 'setting a default value for the counter
    Worksheets(1).Activate
    For Each rngCell In Worksheets("Word").Range("A3", Cells(Rows.Count, "A").End(xlUp))
        vArray = Split(rngCell.Value, " ") 'spliting the value when there is a space
        vrWordIssue = ""
        ElementCounter = ElementCounter + 1 'increases the counter every loop
        For lngLoop = LBound(vArray) To UBound(vArray)

            If Application.WorksheetFunction.CountIf(Sheets("Issue").Range("A2:A" & Sheets("Issue").UsedRange.Rows.Count), vArray(lngLoop)) > 0 Then 'this is to test if the word exist in the Issue Sheet.
                If vrWordIssue = "" Then
                    vrWordIssue = vArray(lngLoop) 'assigning the word
                Else
                    If InStr(1, vrWordIssue, vArray(lngLoop)) = 0 Then 'a binary of comparison
                        vrWordIssue = vrWordIssue & ", " & vArray(lngLoop) 'this will concatinate words issue that exist in Issue Sheet
                    End If
                End If
            End If

        Next lngLoop

        Worksheets("Word").Range("B" & ElementCounter).Value = vrWordIssue 'entering the final word issue list into cell.
    Next rngCell

End Sub
4

1 に答える 1

0

興味があれば、いくつかのコードについて簡単にコメントしてください。

Dim lngLoop, lngLastRow As Long

lngLoopは実際にはバリアントであり、長くはありません。残念ながら、たとえばC ++の場合のように、このようなデータ型を宣言することはできません。

代わりにこれを行う必要があります：

Dim lngLoop As Long, lngLastRow As Long

また、WordIssue使用されることはありません。あるはずvrWordIssueです。

実際、VBAではVariantを使用することはほとんどありません。そのWebサイトのこの作成者は、かなりの量のVBAを知っているとは思いません。（少なくとも、彼らがそれを書いたときではありません）

そうは言っても、私が最初に修正するのは変数です。

から：

Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range

に：

Dim vArray As Variant
Dim vrWordIssue As String
Dim ElementCounter As Long
Dim lngLoop As Long, lngLastRow As Long
Dim rngCell As Range, rngStoplist As Range

Option Explicitそして、モジュールの上部に追加します。これはデバッグに役立ちます。

...そして、Activateを何かに使用する必要はほとんどありません...

....あのね？まったく別のアプローチを使用します。私はこのコードが正直であるのが好きではありません。

本格的なソリューションを提供することは推奨されていないことは知っていますが、あまり良くないコードがそのように広まっているのは好きではありません（DouglasがリンクしたWebサイトから、必ずしもDouglasがこれを書いたわけではありません）。

これが私がすることです。ちなみに、これは大文字と小文字を区別する問題の単語をチェックします。

Option Explicit

Public Type Issues
    Issue As String
    Count As Long
End Type

Const countTolerance As Long = 5

Public Sub WordIssues()
' Main Sub Procedure - calls other subs/functions
    Dim sh As Excel.Worksheet
    Dim iLastRow As Long, i As Long
    Dim theIssues() As Issues

    Set sh = ThisWorkbook.Worksheets("Word")
    theIssues = getIssuesList()
    iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row

    ' loop through worksheet Word
    For i = 3 To iLastRow
        Call evaluateIssues(sh.Cells(i, 1), theIssues)
        Call clearIssuesCount(theIssues)
    Next i
End Sub


Private Function getIssuesList() As Issues()
    ' returns a list of the issues as an array
    Dim sh As Excel.Worksheet
    Dim i As Long, iLastRow As Long
    Dim theIssues() As Issues
    Set sh = ThisWorkbook.Sheets("Issue")

    iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
    ReDim theIssues(iLastRow - 2)

    For i = 2 To iLastRow
        theIssues(i - 2).Issue = sh.Cells(i, 1).Value
    Next i

    getIssuesList = theIssues
End Function

Private Sub clearIssuesCount(ByRef theIssues() As Issues)
    Dim i As Long

    For i = 0 To UBound(theIssues)
        theIssues(i).Count = 0
    Next i
End Sub


Private Sub evaluateIssues(ByRef r As Excel.Range, ByRef theIssues() As Issues)
    Dim vArray As Variant
    Dim i As Long, k As Long
    Dim sIssues As String
    vArray = Split(r.Value, " ")

    ' loop through words in cell, checking for issue words
    For i = 0 To UBound(vArray)
        For k = 0 To UBound(theIssues)
            If (InStr(1, vArray(i), theIssues(k).Issue, vbBinaryCompare) > 0) Then
                'increase the count of issue word
                theIssues(k).Count = theIssues(k).Count + 1
            End If
        Next k
    Next i

    ' loop through issue words and see if it meets tolerance
    ' if it does, add to the Word Issue cell to the right
    For k = 0 To UBound(theIssues)
        If (theIssues(k).Count >= countTolerance) Then
            If (sIssues = vbNullString) Then
                sIssues = theIssues(k).Issue
            Else
                sIssues = sIssues & ", " & theIssues(k).Issue
            End If
        End If
    Next k

    r.Offset(0, 1).Value = sIssues
End Sub
于 2013-03-04T20:24:21.467 に答える