Lernu Esperanton! 理論的に作られた国際共通語エスペラントを学びませんか

単語分析するためのマクロ

2016.01.11 カテゴリ：PC

単語分析するためのマクロ

『ジェーン・エア』の使用語彙を調べましたが、
そのExcelマクロを紹介します。

まずシートです。
langetoj.jpg

  • originalo = 調べたい本文を置くシートです。
    区切り文字はスペース(1バイト,半角)です。
    1セル255字以内になるようにします。
  • listigo = これが語彙調べのメインです。
    trovilo.jpg
    • Listiguで語彙をリスト化してこのシートに表示します。
      　『ジェーン・エア』第1章なら、動作時間は1秒ほどです。
    • Ordigu lau multecoで頻度順リストにします。
    • Ordigu lau alfabetoでアルファベート順にします。
    • Resversigu!で単語の後ろがわから並べたリストにします。
    • 左の黄色い部分が結果の統計です。
  • trovo = できあがったリストを見てまちがいにきづいたとき、
    originaloのどの行にあるか検索します。

では、マクロです。

divido -- 上のListiguからcallします
multeco -- 上のOrdigu lau multecoからcallします
alfabeto -- 上のOrdigu lau alfabetoからcallします
renverso -- 上のRenversigu!からcallします
sercxo -- trovoシート上で動かします

Sub divido()

'belmonto, 2011-11-11
'korektado 2011-11-20, 23
'korektado 2011-12-10
'korektado 2013-01-25 por Ubunto. forigo de japana k korea lingvo
'aldono de indekso 2013-01-31

'    If CommandButton6_Click = True Then MsgBox "esp"

    Let jes = "1"
    Let ne = "2"
    Let distingo = InputBox("Distingi majusklon kaj minsklon?" & vbCr & _
            "1 = jes　　2 = ne")
    Let indekso = InputBox("Fari indekson?" & vbCr & _
            "1 = jes　　2 = ne") '<--2013-01-31

'    ActiveWindow.WindowState = xlMinimized
    Application.ScreenUpdating = False

    Dim vortaro(50000, 1) As String '<-- (50000) 2013-01-31
    Let nova = 0

    Cells.Select
    Selection.ClearContents
    Range("A1").Select

    Do
        Let vertikalo = vertikalo + 1
        Let unulinio = Sheets("originalo").Cells(vertikalo, 1)

        If Left(unulinio, 1) = "#" Then GoTo eliro '<-- 2013-01-28 1文字目#は注釈行とし、処理から外す

        If indekso = jes Then '<--2013-01-31
            Let pagxkomenco = InStr(unulinio, "p") + 1
            Let pagxfino = InStr(unulinio, "】")
            Let pagxnumero = Mid(unulinio, pagxkomenco, pagxfino - pagxkomenco)
        End If

        If InStr(unulinio, "】") > 0 Then '<-- 2013-01-28 "】"より前は処理しない
            Let unulinio = Right(unulinio, Len(unulinio) - InStr(unulinio, "】"))
        End If

        Let longeco = Len(unulinio)
        Let komenco = 0
        For sumo = 1 To longeco
            Let komenco = komenco + 1
            Let spaceto = InStr(komenco, unulinio, " ")
            If spaceto <> 0 Then
                Let vorto = Trim(Mid(unulinio, komenco, spaceto - komenco + 1))
                If Left(vorto, 1) = Chr(34) Or Left(vorto, 1) = "(" Or Left(vorto, 1) = "「" Then
                    Let vorto = Right(vorto, (Len(vorto) - 1))
                End If
                If Right(vorto, 2) = "," & Chr(34) Or Right(vorto, 2) = "." & Chr(34) _
                        Or Right(vorto, 2) = "!" & Chr(34) Or Right(vorto, 2) = "?" & Chr(34) _
                        Or Right(vorto, 2) = "?," Or Right(vorto, 2) = Chr(34) & "." Then
                   Let vorto = Left(vorto, (Len(vorto) - 2))
                End If
                If Right(vorto, 1) = "," Or Right(vorto, 1) = "." _
                        Or Right(vorto, 1) = "!" Or Right(vorto, 1) = "?" _
                        Or Right(vorto, 1) = Chr(34) Or Right(vorto, 1) = ":" _
                        Or Right(vorto, 1) = ";" Or Right(vorto, 1) = "-" _
                        Or Right(vorto, 1) = ")" Or Right(vorto, 1) = "」" _
                        Or Right(vorto, 1) = "=" _
                        Or Right(vorto, 1) = "。" Or Right(vorto, 1) = "、" Then
                    Let vorto = Left(vorto, (Len(vorto) - 1))
                End If
            Else
                Let vorto = Trim(Mid(unulinio, komenco))
                If Left(vorto, 1) = Chr(34) Or Left(vorto, 1) = "(" Or Left(vorto, 1) = "「" Then
                    Let vorto = Right(vorto, (Len(vorto) - 1))
                End If
                If Right(vorto, 2) = "," & Chr(34) Or Right(vorto, 2) = "." & Chr(34) _
                        Or Right(vorto, 2) = "!" & Chr(34) Or Right(vorto, 2) = "?" & Chr(34) _
                        Or Right(vorto, 2) = "?," Or Right(vorto, 2) = Chr(34) & "." Then
                   Let vorto = Left(vorto, (Len(vorto) - 2))
                End If
                If Right(vorto, 1) = "," Or Right(vorto, 1) = "." _
                        Or Right(vorto, 1) = "!" Or Right(vorto, 1) = "?" _
                        Or Right(vorto, 1) = Chr(34) Or Right(vorto, 1) = ":" _
                        Or Right(vorto, 1) = ";" Or Right(vorto, 1) = "-" _
                        Or Right(vorto, 1) = ")" Or Right(vorto, 1) = "」" _
                        Or Right(vorto, 1) = "。" Or Right(vorto, 1) = "、" Then
                    Let vorto = Left(vorto, (Len(vorto) - 1))
                End If
                Let nova = nova + 1
                'Let vortaro(nova) = vorto
                Let vortaro(nova, 0) = vorto '<--2013-01-31
                Let vortaro(nova, 1) = pagxnumero '<--2013-01-31
               GoTo eliro
            End If
            Let nova = nova + 1
            'Let vortaro(nova) = vorto
            Let vortaro(nova, 0) = vorto '<--2013-01-31
            Let vortaro(nova, 1) = pagxnumero '<--2013-01-31

            Let komenco = spaceto
        Next
eliro:
    Loop Until Sheets("originalo").Cells(vertikalo + 1, 1) = Empty 'aldono 2011-11-20

    For listo = 1 To nova
        'Let Cells(listo, 1) = vortaro(listo)
        Let Cells(listo, 1) = vortaro(listo, 0) '<--2013-01-31
        Let Cells(listo, 3) = vortaro(listo, 1) '<--2013-01-31
    Next

    Range("A1").Select
    'Let dumo = "a1:a" & Trim(Str(nova))
    Let dumo = "a1:c" & Trim(Str(nova))
    Range(dumo).Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("A3"), _
        Order1:=xlAscending, Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, Orientation:=xlTopToBottom

    Do
        If Cells(1, 1) = Empty Then
            'Range("a1").Select
            Range("a1:c1").Select '<--2013-01-31
            Selection.Delete Shift:=xlUp
        End If
    Loop Until Cells(1, 1) <> ""

    For linio = 2 To nova
        If Cells(linio, 1) <> "" Then
            If distingo = jes Then
                Let nuno = Cells(linio, 1)
                Let antauo = Cells(linio - 1, 1)
            Else
                Let nuno = LCase(Cells(linio, 1))
                Let antauo = LCase(Cells(linio - 1, 1))
            End If

            If nuno = antauo Then
                If Cells(linio - 1, 2) = 0 Then Cells(linio - 1, 2) = 1
                Let Cells(linio - 1, 2) = Cells(linio - 1, 2) + 1

                Let Cells(linio - 1, 3) = Cells(linio - 1, 3) & " " & Cells(linio, 3) '<--2013-01-31
                Let antaunumero = Cells(linio, 3)

                'Let loko = "a" & Trim(Str(linio))
                Let loko = "a" & Trim(Str(linio)) & ":c" & Trim(Str(linio)) '<--2013-01-31
                Range(loko).Select
                Selection.Delete Shift:=xlUp
                Let linio = linio - 1
            End If
        End If
    Next

    Do
        Let numero = numero + 1
    Loop Until Cells(numero, 1) = ""

    Let vortoj = numero - 1


    '2013-02-01 aldono por forigi samnumeron po vorto ------------

    For linio = 1 To vortoj
        Let novlinio = ""
        Let unulinio = Cells(linio, 3)

        Let spaceto = InStr(unulinio, " ")
        If spaceto = 0 Then
            Let trapasi = jes
        Else
            Let trapasi = ne
        End If

        Do While spaceto > 0
            Let num = Left(unulinio, spaceto - 1)
            Let unulinio = Right(unulinio, Len(unulinio) - spaceto)

            If num <> malnova Then
                Let malnova = num
                Let novlinio = novlinio & " " & num
            End If
            Let spaceto = InStr(unulinio, " ")
        Loop

        If trapasi = ne Then
            Let Cells(linio, 3) = novlinio
        End If
    Next

    '2013-02-01-------------------------- fino

    For linio = 1 To vortoj
        If Cells(linio, 2) = "" Then
            Let sumo = sumo + 1
        Else
            Let sumo = sumo + Cells(linio, 2) - 1
        End If
    Next

    Columns("A:A").Select
    With Selection
        .HorizontalAlignment = xlLeft
    End With
    Range("A1").Select

    '3->4, 4->5 '<--2013-01-31
    Let Cells(1, 4) = "MAJ/min"
    Let Cells(2, 4) = "Vortosumo"
    Let Cells(3, 4) = "Malsamaj Vortoj"
    Let Cells(4, 4) = "Procentoj de Malsameco"
    Let Cells(1, 5) = "Distingo"
    If distingo = ne Then
        Let Cells(1, 5) = "Sen Distingo"
    End If
    Let Cells(2, 5) = sumo
    Let Cells(3, 5) = vortoj
    Let Cells(4, 5) = Int(vortoj * 1000 / sumo) / 10 & " %"
    'gxis cxi tie '<--2013-01-31

    Range("A1").Select

'    ActiveWindow.WindowState = xlMaximized
    Application.ScreenUpdating = True

End Sub
Sub multeco()

'belmonto, 2011-11-20
'korektado 2011-11-23
'korektado 2011-12-10
'korektado por aldono de indekso 2013-01-31

    Application.ScreenUpdating = False

    'Columns("A:B").Select
    Columns("A:C").Select '<-- 2013-01-31
    Selection.Sort Key1:=Range("B1"), Order1:=xlDescending, Key2:=Range("A1") _
        , Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=True _
        , Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
        xlSortNormal, DataOption2:=xlSortNormal
    Columns("A:A").Select
    Selection.HorizontalAlignment = xlLeft
    Range("A1").Select

    Application.ScreenUpdating = True
End Sub
Sub alfabeto()

'belmonto, 2011-11-20
'korektado 2011-11-23
'korektado 2011-12-10
'korektado por aldono de indekso 2013-01-31

    Application.ScreenUpdating = False
    'Columns("A:B").Select
    Columns("A:C").Select '<-- 2013-01-31
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=True, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin, DataOption1:=xlSortNormal
    Columns("A:A").Select
    Selection.HorizontalAlignment = xlLeft
    Range("A1").Select
    Application.ScreenUpdating = True

End Sub
Sub renverso()

'belmonto, 2011-11-20
'korektado 2011-11-23
'korektado 2011-12-10
'korektado por aldono de indekso 2013-01-31

    Application.ScreenUpdating = False

    Let vertikalo = 0
    Do
        Let vertikalo = vertikalo + 1
        Let vorto = Cells(vertikalo, 1)
        Let longeco = Len(vorto)
        Let malo = ""
        For ripeto = longeco To 1 Step -1
            Let malo = malo & Mid(vorto, ripeto, 1)
        Next
        Let Cells(vertikalo, 1) = malo
    Loop Until Cells(vertikalo + 1, 1) = Empty

    'Columns("A:B").Select
    Columns("A:C").Select '<-- 2013-01-31
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=True, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin, DataOption1:=xlSortNormal

    Let vertikalo = 0
    Do
        Let vertikalo = vertikalo + 1
        Let vorto = Cells(vertikalo, 1)
        Let longeco = Len(vorto)
        Let malo = ""
        For ripeto = longeco To 1 Step -1
            Let malo = malo & Mid(vorto, ripeto, 1)
        Next
        Let Cells(vertikalo, 1) = malo
    Loop Until Cells(vertikalo + 1, 1) = ""

    Columns("A:A").Select
    Selection.HorizontalAlignment = xlRight
    Range("A1").Select

    Application.ScreenUpdating = True
End Sub
Sub sercxo()

'belmonto, 2011-11-11

    Dim frazo(2000, 2)

    Columns("A:A").Select
    Selection.NumberFormatLocal = "@"
    Range("A1").Select

    Let celvorto = Cells(1, 1).Value
    Let celvorto = LCase(celvorto)

    Do
        Let linio = linio + 1
        Let linio2 = LCase(Sheets("originalo").Cells(linio, 1).Value)
        Let longeco = Len(linio2)

        For iro = 1 To longeco
            If InStr(iro, linio2, celvorto) > 0 Then
                Let numero = numero + 1
                Let frazo(numero, 1) = linio
                Let frazo(numero, 2) = Sheets("originalo").Cells(linio, 1)
                Let iro = longeco
            End If
        Next
    Loop Until Sheets("originalo").Cells(linio + 1, 1) = Empty

    Cells.Select
    Selection.ClearContents
    Range("A1").Select

    Let Cells(1, 1) = celvorto
    For pozicio = 1 To numero
        Let Cells(pozicio + 2, 1) = frazo(pozicio, 1) & ": " & frazo(pozicio, 2)
    Next

End Sub

a:2600 t:1 y:0

コメント



認証コード3563

コメントは管理者の承認後に表示されます。

powered by Quick Homepage Maker 4.91
based on PukiWiki 1.4.7 License is GPL. QHM

最新の更新 RSS  Valid XHTML 1.0 Transitional