excel.frm

使用说明： 1.打开电子表格文档－－全选－－复制 2.切换到本程序－－全选－－粘贴 3.选择匹配项：匹配条件 4.选择输出项：将要产生合并的项 5.点击保存按钮－－结束。 欢迎访问：www.digit

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "表格处理      作者:Yingang"
   ClientHeight    =   3570
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8790
   Icon            =   "Excel.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3570
   ScaleWidth      =   8790
   StartUpPosition =   3  '窗口缺省
   Begin VB.Frame Frame2 
      Caption         =   "输出项"
      Height          =   735
      Left            =   3600
      TabIndex        =   8
      Top             =   2760
      Width           =   2775
      Begin VB.CheckBox Check2 
         Caption         =   "5"
         Height          =   375
         Index           =   4
         Left            =   2160
         TabIndex        =   13
         Top             =   240
         Width           =   495
      End
      Begin VB.CheckBox Check2 
         Caption         =   "4"
         Height          =   375
         Index           =   3
         Left            =   1680
         TabIndex        =   12
         Top             =   240
         Width           =   495
      End
      Begin VB.CheckBox Check2 
         Caption         =   "3"
         Height          =   375
         Index           =   2
         Left            =   1200
         TabIndex        =   11
         Top             =   240
         Width           =   495
      End
      Begin VB.CheckBox Check2 
         Caption         =   "2"
         Height          =   375
         Index           =   1
         Left            =   720
         TabIndex        =   10
         Top             =   240
         Width           =   495
      End
      Begin VB.CheckBox Check2 
         Caption         =   "1"
         Height          =   375
         Index           =   0
         Left            =   240
         TabIndex        =   9
         Top             =   240
         Width           =   495
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "匹配项："
      Height          =   735
      Left            =   120
      TabIndex        =   2
      Top             =   2760
      Width           =   2775
      Begin VB.CheckBox Check1 
         Caption         =   "5"
         Height          =   375
         Index           =   4
         Left            =   2160
         TabIndex        =   7
         Top             =   240
         Width           =   495
      End
      Begin VB.CheckBox Check1 
         Caption         =   "4"
         Height          =   375
         Index           =   3
         Left            =   1680
         TabIndex        =   6
         Top             =   240
         Width           =   495
      End
      Begin VB.CheckBox Check1 
         Caption         =   "3"
         Height          =   375
         Index           =   2
         Left            =   1200
         TabIndex        =   5
         Top             =   240
         Width           =   495
      End
      Begin VB.CheckBox Check1 
         Caption         =   "2"
         Height          =   375
         Index           =   1
         Left            =   720
         TabIndex        =   4
         Top             =   240
         Width           =   495
      End
      Begin VB.CheckBox Check1 
         Caption         =   "1"
         Height          =   375
         Index           =   0
         Left            =   240
         TabIndex        =   3
         Top             =   240
         Width           =   495
      End
   End
   Begin VB.TextBox Text1 
      Height          =   2655
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Text            =   "Excel.frx":030A
      Top             =   0
      Width           =   8535
   End
   Begin VB.CommandButton CmdSave 
      Caption         =   "保存"
      Height          =   495
      Left            =   7560
      TabIndex        =   0
      Top             =   3000
      Width           =   1095
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Type aLine
    LineNo As Integer
    Str1 As String
    Str2 As String
    Str3 As String
    Str4 As String
    Str5 As String
End Type
Private FgaLine As Boolean
Private MyLine(1000) As aLine
Private OutArray(1000) As aLine

Private Sub CmdSave_Click()
Dim I As Integer, J As Integer
Dim EndPos1 As Long
Dim EndPos2 As Long
Dim StrTemp As String
Dim FgNotFirst As Boolean
Dim Str As String
Dim Number As Integer
Dim FgMatch As Boolean
Dim FgMatch1 As Boolean
Dim FgMatch2 As Boolean
Dim FgMatch3 As Boolean
Dim FgMatch4 As Boolean
Dim FgMatch5 As Boolean
'--------------------------------------------------------           '分解成aLine结构
    If Not CheckCheckbox Then
        MsgBox "请确认匹配项与输出项！"
        Exit Sub
    End If
    If Not CheckTextbox Then
        MsgBox "请确认粘贴内容！"
        Exit Sub
    End If
    EndPos1 = 1
    EndPos2 = 1
    StrTemp = Text1.Text
    Do While 1
            If Not FgNotFirst Then
                FgNotFirst = True
                Str = Left$(StrTemp, InStr(StrTemp, vbCrLf) + 1)
            Else
                EndPos1 = InStr(EndPos1, StrTemp, vbCrLf)
                EndPos2 = InStr(EndPos1 + 1, StrTemp, vbCrLf)
                If EndPos2 = 0 Then Exit Do
                Str = Mid$(StrTemp, EndPos1 + 2, EndPos2 - EndPos1)
            End If
            I = I + 1
            MyLine(I) = Convert(Str)
            MyLine(I).LineNo = I

'            Debug.Print MyLine(I).LineNo
'            Debug.Print MyLine(I).Str1
'            Debug.Print MyLine(I).Str2
'            Debug.Print MyLine(I).Str3
'            Debug.Print MyLine(I).Str4
'            Debug.Print MyLine(I).Str5
            
            EndPos1 = EndPos1 + 1
            EndPos2 = EndPos2 + 1                                   '回车符指针
    Loop
    '--------------------------------------------------------       '排版
    Dim SrcCount As Integer, DestCount As Integer
    Dim FgNotNew As Boolean
    OutArray(1) = MyLine(1)
    Number = I
    I = 2
    Do
        J = 1
        FgNotNew = False
        Do
            If OutArray(J).Str1 = MyLine(I).Str1 Then
                FgMatch1 = True
            Else: FgMatch1 = False
            End If
            If OutArray(J).Str2 = MyLine(I).Str2 Then
                FgMatch2 = True
            Else: FgMatch2 = False
            End If
            If OutArray(J).Str3 = MyLine(I).Str3 Then
                FgMatch3 = True
            Else: FgMatch3 = False
            End If
            If OutArray(J).Str4 = MyLine(I).Str4 Then
                FgMatch4 = True
            Else: FgMatch4 = False
            End If
            If OutArray(J).Str5 = MyLine(I).Str5 Then
                FgMatch5 = True
            Else: FgMatch5 = False
            End If
            '---------------------------------------------以上FgMatch各项匹配情况
            '---------------------------------------------以下生成用户匹配值
            FgMatch = True
            If Check1(0).Value = 1 Then
                If OutArray(J).Str1 = MyLine(I).Str1 Then
                    FgMatch = True
                Else: FgMatch = False
                End If
            End If
            If Check1(1).Value = 1 Then
                If FgMatch2 Then
                    FgMatch = FgMatch And FgMatch2
                Else: FgMatch = False
                End If
            End If
            If Check1(2).Value = 1 Then
                If FgMatch3 Then
                    FgMatch = FgMatch And FgMatch3
                Else: FgMatch = False
                End If
            End If
            If Check1(3).Value = 1 Then
                If FgMatch4 Then
                    FgMatch = FgMatch And FgMatch4
                Else: FgMatch = False
                End If
            End If
            If Check1(4).Value = 1 Then
                If FgMatch5 Then
                    FgMatch = FgMatch And FgMatch5
                Else: FgMatch = False
                End If
            End If
            If FgMatch Then                     '匹配则更新匹配项
                If Check2(0).Value = 1 Then OutArray(J).Str1 = OutArray(J).Str1 & "," & MyLine(I).Str1
                If Check2(1).Value = 1 Then OutArray(J).Str2 = OutArray(J).Str2 & "," & MyLine(I).Str2
                If Check2(2).Value = 1 Then OutArray(J).Str3 = OutArray(J).Str3 & "," & MyLine(I).Str3
                If Check2(3).Value = 1 Then OutArray(J).Str4 = OutArray(J).Str4 & "," & MyLine(I).Str4
                If Check2(4).Value = 1 Then OutArray(J).Str5 = OutArray(J).Str5 & "," & MyLine(I).Str5
                FgNotNew = True
            End If
            J = J + 1
        Loop Until OutArray(J).LineNo = 0       '比较输出数组全部元素与源数组第 I 项
        If Not FgNotNew Then                    '如果不曾覆盖，则产生新的记录
            OutArray(J) = MyLine(I)
        End If
        I = I + 1
    Loop Until MyLine(I).LineNo = 0

    J = 1
On Error GoTo ErrorHandle
    Dim FileNo As Integer
    FileNo = FreeFile(1)
    Open "Yingang.xls" For Output As FileNo
    StrTemp = ""
    Do
        Do
            StrTemp = OutArray(J).Str1 & vbTab
            StrTemp = StrTemp & OutArray(J).Str2 & vbTab
            StrTemp = StrTemp & OutArray(J).Str3 & vbTab
            StrTemp = StrTemp & OutArray(J).Str4 & vbTab
            StrTemp = StrTemp & OutArray(J).Str5
            Debug.Print StrTemp
            J = J + 1
            Print #FileNo, StrTemp
        Loop Until OutArray(J).LineNo = 0
    Loop Until OutArray(J).LineNo = 0
    Close #FileNo
    
    MsgBox "已生成文件 Yingang.xls"
    Unload Me
    Exit Sub
ErrorHandle:
    MsgBox "文件已打开，请先关闭文件", vbOKOnly
End Sub

Private Function CheckCheckbox() As Boolean
    Dim I As Integer
    Dim Flag1 As Boolean
    Dim Flag2 As Boolean
    For I = 0 To 4
        Flag1 = Flag1 Or Check1(I).Value
        Flag2 = Flag2 Or Check2(I).Value
    Next
    If Not Flag1 Or Not Flag2 Then
        CheckCheckbox = False
    Else: CheckCheckbox = True
    End If
End Function

Private Function CheckTextbox() As Boolean
    If InStr(Text1.Text, vbTab) > 0 Then
        CheckTextbox = True
    Else
        CheckTextbox = False
    End If
End Function


Private Function Convert(ByVal Str As String) As aLine
    Dim Times As Integer
    Dim oneline As aLine
    Dim Pos1 As Long
    Dim Pos2 As Long
    Dim FgNotFirst As Boolean
    Dim FgOver As Boolean
    Dim StrTemp As String
    On Error Resume Next
    oneline.LineNo = Times
    Pos1 = 1
    Pos2 = 1
    If Text1.Text = "" Then Exit Function
    Do While Not FgOver                             '当发现pos2为 0 ，则是结束标志
        If Not FgNotFirst Then
            FgNotFirst = True
            StrTemp = Left$(Str, InStr(Str, vbTab) - 1)
        Else
            Pos1 = InStr(Pos1, Str, vbTab)
            Pos2 = InStr(Pos1 + 1, Str, vbTab)
            If Pos2 = 0 Then
                Pos2 = InStr(Pos1 + 1, Str, vbCrLf) '以回车符为结束点
                FgOver = True
            End If
            StrTemp = Mid$(Str, Pos1 + 1, Pos2 - Pos1 - 1)
        End If
        Times = Times + 1
        Select Case Times
            Case 1
                oneline.Str1 = StrTemp
            Case 2
                oneline.Str2 = StrTemp
            Case 3
                oneline.Str3 = StrTemp
            Case 4
                oneline.Str4 = StrTemp
            Case 5
                oneline.Str5 = StrTemp
        End Select
        Pos1 = Pos1 + 1
        Pos2 = Pos2 + 1
    Loop
    Convert = oneline
End Function

Private Sub Form_Load()
    Dim I As Integer
    For I = 1 To 1000
        MyLine(I).LineNo = 0
        OutArray(I).LineNo = 0
    Next
    Check1(0).Value = 1
    Check1(1).Value = 1
    Check2(2).Value = 1
End Sub