Oscar Sun on SnipSave | Web-based code snippet manager for developers

詞學韻字相似度比對

                    Sub 詞學韻字相似度比對()
rt = Sheets(1).UsedRange.Rows.Count
cou = 1
For i = 2 To rt
    X = Sheets(1).Cells(i, "j") '韻字欄位
    If X = "" Then MsgBox "韻字欄位無資料!!", vbExclamation: GoTo N
    xL = Len(X)
    For j = i + 1 To rt
        y = Sheets(1).Cells(j, "j")
        yL = Len(y)
        If Abs(yL - xL) / xL <= 1 / 2 Then '字串長度不能差太多
            For Z = 1 To xL
                If InStr(1, y, Mid(X, Z, 1), vbTextCompare) > 0 Then
                'If StrComp(Mid(x, z, 1), Mid(y, z, 1), vbTextCompare) = 0 Then
                    samecount = samecount + 1
                End If
            Next Z
            If samecount / xL > 0.5 Then
                If cou = Sheets(2).Rows.Count Then MsgBox "筆數太多,超出Excel工作表的上限了...", vbExclamation: End
                cou = cou + 1
                Sheets(2).Cells(cou, 1) = Sheets(1).Cells(i, "a") 'ID或序號-取以比對詞作
                Sheets(2).Cells(cou, 2) = Sheets(1).Cells(j, "a") 'ID或序號-被比對詞作
                Sheets(2).Cells(cou, 3) = Sheets(1).Cells(i, "f") '首句-取以比對詞作
                Sheets(2).Cells(cou, 4) = Sheets(1).Cells(j, "f") '首句-被比對詞作
                Sheets(2).Cells(cou, 5) = Sheets(1).Cells(i, "j") '韻字-取以比對詞作
                Sheets(2).Cells(cou, 6) = Sheets(1).Cells(j, "j") '韻字-被比對詞作
                '會有一對多的關係
'                If Cells(i, "n") = "" Then
'                    Cells(j, "n") = Cells(i, "o")
'                Else
'                    Stop
'                    Cells(j, "p") = Cells(i, "o")
'
'                End If
            End If
        End If
        samecount = 0
    Next j
N:
Next i
End Sub

詞學韻字相似度比對

View Snippet

                    Sub 詞學韻字相似度比對()
rt = ActiveSheet.UsedRange.Rows.Count
cou = 1
For i = 2 To rt
    x = Cells(i, "k")
    xL = Len(x)
    For j = i + 1 To rt
        y = Cells(j, "k")
        yL = Len(y)
        If Abs(yL - xL) / xL <= 1 / 2 Then '字串長度不能差太多
            For z = 1 To xL
                If InStr(1, y, Mid(x, z, 1), vbTextCompare) > 0 Then
                'If StrComp(Mid(x, z, 1), Mid(y, z, 1), vbTextCompare) = 0 Then
                    samecount = samecount + 1
                End If
            Next z
            If samecount / xL > 0.5 Then
                cou = cou + 1
                Sheet2.Cells(cou, 1) = Cells(i, "o")
                Sheet2.Cells(cou, 2) = Cells(j, "o")
                Sheet2.Cells(cou, 3) = Cells(i, "e")
                Sheet2.Cells(cou, 4) = Cells(j, "e")
                Sheet2.Cells(cou, 5) = Cells(i, "k")
                Sheet2.Cells(cou, 6) = Cells(j, "k")
                '會有一對多的關係
'                If Cells(i, "n") = "" Then
'                    Cells(j, "n") = Cells(i, "o")
'                Else
'                    Stop
'                    Cells(j, "p") = Cells(i, "o")
'
'                End If
            End If
        End If
        samecount = 0
    Next j
Next i
End Sub

設定引用項目-VBA

View Snippet

                    Attribute VB_Name = "設定引用項目"
Sub AddReference_old()
On Error Resume Next
'
'   Dim vbProj As VBProject
'
'   Set vbProj = ActiveWorkbook.VBProject
'   vbProj.References.AddFromFile "C:\Program Files\Microsoft Office\Office14\MSWORD.OLB"
    Application.ThisWorkbook.VBProject.References.AddFromFile "C:\Program Files\Microsoft Office\Office14\MSWORD.OLB"
    'Application.ThisWorkbook.VBProject.References.VBE.VBProjects
End Sub


Sub AddReference()
On Error Resume Next
With Application.VBE.ActiveVBProject.References
    .AddFromFile "C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB"
    .AddFromFile "c:\program files\microsoft office\office14\msword.olb"
End With
'http://www.mrexcel.com/forum/excel-questions/590567-use-visual-basic-applications-install-excel-reference.html
''http://support.microsoft.com/kb/308340/zh-tw
'   Dim vbProj As VBProject
'
'   Set vbProj = ActiveWorkbook.VBProject
'   'vbProj.References.AddFromFile "C:\TestFiles\Refme.dot"
'   vbProj.References.AddFromFile "c:\program files\microsoft office\office14\msword.olb"
''按一下 [工具] 功能表上的 [設定引用項目]，然後將參考加入 Microsoft Visual Basic for Applications Extensibility 5.3 程式庫中。此程式庫包含參考 VBA 專案的物件。
''"C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6"
End Sub


Sub AddReference()
On Error Resume Next
With Application.VBE.ActiveVBProject.References
    .AddFromFile "C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB"
    .AddFromFile "c:\program files\microsoft office\office14\msword.olb"
End With
'http://www.mrexcel.com/forum/excel-questions/590567-use-visual-basic-applications-install-excel-reference.html
''http://support.microsoft.com/kb/308340/zh-tw
'   Dim vbProj As VBProject
'
'   Set vbProj = ActiveWorkbook.VBProject
'   'vbProj.References.AddFromFile "C:\TestFiles\Refme.dot"
'   vbProj.References.AddFromFile "c:\program files\microsoft office\office14\msword.olb"
''按一下 [工具] 功能表上的 [設定引用項目]，然後將參考加入 Microsoft Visual Basic for Applications Extensibility 5.3 程式庫中。此程式庫包含參考 VBA 專案的物件。
''"C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6"
End Sub

比對說文資料庫之資料.bas

View Snippet

                    Sub AddReference()
On Error Resume Next
With Application.VBE.ActiveVBProject.References
    .AddFromFile "C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB"
    .AddFromFile "c:\program files\microsoft office\office14\msword.olb"
End With
'http://www.mrexcel.com/forum/excel-questions/590567-use-visual-basic-applications-install-excel-reference.html
''http://support.microsoft.com/kb/308340/zh-tw
'   Dim vbProj As VBProject
'
'   Set vbProj = ActiveWorkbook.VBProject
'   'vbProj.References.AddFromFile "C:\TestFiles\Refme.dot"
'   vbProj.References.AddFromFile "c:\program files\microsoft office\office14\msword.olb"
''按一下 [工具] 功能表上的 [設定引用項目]，然後將參考加入 Microsoft Visual Basic for Applications Extensibility 5.3 程式庫中。此程式庫包含參考 VBA 專案的物件。
''"C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6"
End Sub

Sub 比對說文資料庫之資料()
Dim D As Document, P As Paragraph, S As Worksheet
Set S = ActiveSheet
If D Is Nothing Then Set D = Word.Application.ActiveDocument
i = 1: J = 1
With D
    For Each P In D.Paragraphs
        If P.Range.Characters(1) = "0" Then
            Do Until StrComp(P.Range.Characters(i), "（") = 0
                i = i + 1
            Loop
            x = P.Range.Characters(i + 1)
            TXT = P.Range
            ID = Val(Mid(TXT, 1, InStr(1, TXT, "　", vbTextCompare)))
            
            With S
                Do Until .Cells(J, "C") = ID '含重文序號
                    J = J + 1
                Loop
                If StrComp(x, .Cells(J, "k")) <> 0 Then '楷體
                    .Cells(J, "k").Select
                    P.Range.Select
                    AppActivate "MICROSOFT EXCEL"
                    'Stop
                    If MsgBox("是否增補此字？", vbQuestion + vbOKCancel) = vbCancel Then
                        GoTo 1
                    Else
    '                   .Rows(J).Select
    '                   Selection.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
                        '.Cells(J, 2).Activate
                        Application.CutCopyMode = False
                        .Rows(J).Insert 'Shift:=xlDown
                        .Rows(J).Select
                        With Selection.Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = 65535
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                       .Cells(J, 2) = .Cells(J - 1, 2)
                       .Cells(J, 2).Font.Color = RGB(255, 0, 0)
                       .Cells(J - 1, 2).Font.Color = RGB(255, 0, 0)
                       .Cells(J, 3) = .Cells(J - 1, 3) + 1
                       .Cells(J, 4) = .Cells(J - 1, 4)
                       .Cells(J, 7) = .Cells(J - 1, 7) 'G
                       .Cells(J, 8) = .Cells(J - 1, 8) 'H
                       .Cells(J, 9) = .Cells(J - 1, 9) 'I
                       .Cells(J, "i").Font.Color = RGB(255, 0, 0)
                       .Cells(J - 1, "i").Font.Color = RGB(255, 0, 0)
                       .Cells(J, 10) = .Cells(J - 1, 10) 'J
                       .Cells(J, "j").Font.Color = RGB(255, 0, 0)
                       .Cells(J - 1, "j").Font.Color = RGB(255, 0, 0)
                       .Cells(J, 11) = x 'K
                       .Cells(J, 11).Font.Color = RGB(255, 0, 0)
                       .Cells(J, 12) = x
                       .Cells(J, 12).Font.Color = RGB(255, 0, 0)
                       .Cells(J, 13) = x 'M
                       .Cells(J, 13).Font.Color = RGB(255, 0, 0)
                       .Cells(J, "o") = Mid(TXT, InStr(1, TXT, "，", vbTextCompare) + 1, InStr(InStr(1, TXT, "，", vbTextCompare), TXT, "（", vbTextCompare) - InStr(1, TXT, "，", vbTextCompare) - 1)
                       .Cells(J, "p") = .Cells(J - 1, "p") '反切
                       .Cells(J, "p").Font.Color = RGB(255, 0, 0)
                       .Cells(J, "R") = .Cells(J - 1, "R")
                       .Cells(J, "s") = .Cells(J - 1, "s")
                       .Cells(J, "v") = "補。原書無反切"
                       q = J
                       Do Until .Cells(q + 1, 3) = "" '含重文序號,自動填滿
                            .Cells(q + 1, 3) = .Cells(q, 3) + 1
                            q = q + 1
                       Loop
                       'Stop
                   End If
1               Stop
                End If
            End With
        End If
        i = 1
        J = 1
    Next P
End With


End Sub

開獎程式-隨機發牌-不重複亂碼取號-Poker-Visual Basic 2010基礎必修課(8-38~39)-亦可作抽點點名之用

View Snippet

                    Public Class Form1
    Dim defPic(5) As PictureBox'真按:此應是4就夠,可能為程式引用方便

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        lblRnd.Text = "排序前："
        lblSort.Text = "排序後："
        defPic(1) = pic1 : defPic(2) = pic2 : defPic(3) = pic3
        defPic(4) = pic4 : defPic(5) = pic5
        For i = 0 To 4
            defPic(i + 1).Image = New Bitmap("Pokerbk.jpg")
        Next
    End Sub

    ' GetRnd函式可用來取得n~m之間的num個不重複的亂數，並傳給所設定的陣列
    Sub GetRnd(ByRef vArray() As Integer, ByVal min As Integer, ByVal max As _
   Integer, ByVal num As Integer)
        Dim i, j, max_dim, rem_num, choice As Integer
        max_dim = max - min
        Dim t(max_dim) As Integer
        For i = 0 To max_dim
            t(i) = min + i
        Next
        rem_num = max_dim
        Randomize()
        For i = 0 To num - 1
            choice = Fix(rem_num) * Rnd()
            vArray(i) = t(choice)
            For j = choice To rem_num - 1
                t(j) = t(j + 1)
            Next
            rem_num -= 1'真按:不重複
        Next
    End Sub

    Private Sub btnStart_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnStart.Click
        Dim pk(4) As Integer
        GetRnd(pk, 1, 13, 5)
        lblRnd.Text = "排序前："
        Dim i As Integer
        For i = 0 To 4
            lblRnd.Text &= pk(i) & ", "
        Next
        Array.Sort(pk)
        lblSort.Text = "排序後："
        For i = 0 To 4
            lblSort.Text &= pk(i) & ", "
            defPic(i + 1).Image = New Bitmap("Poker" & pk(i) & ".jpg")
        Next
    End Sub
End Class

← Prev Page Next Page →