tbTitle()

发布日期：2024-06-21 16:03    点击次数：148

您不错通过以下格式复旧我：1、暖和、点赞、留言、共享、打赏；2、点击感趣味的告白、购买我的安利微店产物；3、添加我的合谷医疗企业微信，谢谢！

☆本期实质摘录☆

责任表重叠值解决模板代码

通盘代码均在UserForm1里，宇宙不错把它径直拖到我方的内外，把我方的需要解决重叠值的表改为“明细表”能够，把代码中的“明细表”替换成你的表名。

1、用户窗体运行代码：

Dim arrFields()  '界说在通盘模块外面的变量Private Sub UserForm_Activate()    Dim iRow As Integer， iCol As Integer    Dim topPos As Integer    Sheets("明细表").Activate    With ActiveSheet        iRow = .UsedRange.Rows.Count        iCol = .UsedRange.Columns.Count        For i = 1 To iCol            If Cells(1， i) <> "" Then                ReDim Preserve arrFields(k)                arrFields(k) = Cells(1， i)                k = k + 1            End If        Next    End With    leftPos = Me.LbSelect.Left + 10  ' 复选框的左侧位置    topPos = Me.LbSelect.Top + Me.LbSelect.Height + 10 ' 复选框的顶部位置    For i = LBound(arrFields) To UBound(arrFields)        '在指定位置插入复选框        Me.Controls.Add "Forms.CheckBox.1"， "CheckBox" & i        '开拓复选框的位置和属性        With Me.Controls("CheckBox" & i)            .Left = leftPos            .Top = topPos            .Width = 40            .Height = 20            .Caption = arrFields(i)            .Value = False        End With        '更新位置        If (i + 1) Mod 4 = 0 Then            '换行            leftPos = Me.LbSelect.Left + 10            topPos = topPos + 20        Else            '同业下一个位置            leftPos = leftPos + 40        End If    Next    'StopEnd Sub

2、重叠值标色代码：

Sub HighlightDuplicateRecords()   '重叠值标色    Dim ws As Worksheet    Dim lastRow As Long， lastColumn As Long    Dim colorIndex As Integer    Dim arr()， tbTitle()， arrRows()    Dim duplicateRows As String    Dim markCol As Integer    Dim arrKey() As String    ThisWorkbook.Activate     For i = LBound(arrFields) To UBound(arrFields)        If Me.Controls("CheckBox" & i) = True Then           ReDim Preserve arrKey(k)           arrKey(k) = i + 1           k = k + 1        End If    Next     If k = 0 Then        MsgBox "请至少继承一个科目！"        Exit Sub    End If    Set ws = ThisWorkbook.Sheets("明细表")    ws.Activate    lastRow = ws.UsedRange.Rows.Count    lastColumn = ws.UsedRange.Columns.Count    arr = ws.Range(Cells(1， 1)， Cells(lastRow， lastColumn)).Value    ws.Range(Cells(2， 1)， Cells(lastRow， lastColumn)).Interior.Color = vbWhite    For i = 1 To lastColumn        If arr(1， i) = "是否重叠" Then            t = i        End If    Next    If t > 0 Then        markCol = t    Else        markCol = lastColumn + 1        ws.Cells(1， markCol) = "是否重叠"    End If    ws.Range(Cells(2， markCol)， Cells(lastRow， markCol)).Clear    '记号重叠纪录    Dim pickedRows As String    For i = 2 To lastRow        If InStr(pickedRows， "\" & i & "\") = 0 Then            colorIndex = 1            For m = LBound(arrKey) To UBound(arrKey)                key1 = key1 & arr(i， arrKey(m)) & "|"            Next            For j = i + 1 To lastRow                For m = LBound(arrKey) To UBound(arrKey)                    key2 = key2 & arr(j， arrKey(m)) & "|"                Next                If key2 = key1 Then                    ws.Range(Cells(i， 1)，
苏州海峰贸易有限公司 Cells(i，
首页-达士佳香料有限公司 lastColumn)).Interior.Color = PickColor(0)                    ws.Range(Cells(j，民丰县三南聚合物有限公司 1)， Cells(j， lastColumn)).Interior.Color = PickColor(colorIndex)                                        pickedRows = pickedRows & "\" & j & "\"                    ws.Cells(j， markCol) = "第" & i & "行[" & colorIndex & "次重叠]"                    colorIndex = colorIndex + 1                End If                 key2 = ""            Next        End If        key1 = ""    Next    MsgBox "查重截止！通盘重叠的已标色，无重叠的为白色！"End Sub

3、重叠值删除代码：

Sub DeleteDuplicateRecords()  '删除重叠    Dim ws As Worksheet， destSheet As Worksheet    Dim lastRow As Long， lastColumn As Long    Dim colorIndex As Integer    Dim arr()， tbTitle()    Dim destRow As Integer， firstRow As Integer    Dim arrKey() As String    If Not wContinue("行将删除重叠纪录，此操作不能规复，请说明！") Then Exit Sub    For i = LBound(arrFields) To UBound(arrFields)        If Me.Controls("CheckBox" & i) = True Then            ReDim Preserve arrKey(k)            arrKey(k) = i + 1            k = k + 1        End If    Next    If k = 0 Then        MsgBox "请至少继承一个科目！"        Exit Sub    End If    ThisWorkbook.Activate    Set ws = ThisWorkbook.Sheets("明细表")    ws.Activate    lastRow = ws.UsedRange.Rows.Count    lastColumn = ws.UsedRange.Columns.Count    arr = ws.Range(Cells(1，网站建设 1)， Cells(lastRow， lastColumn)).Value    ws.Range(Cells(2， 1)， Cells(lastRow， lastColumn)).Interior.Color = vbWhite    '记号重叠纪录    Dim pickedRows As String    For i = 2 To lastRow        If InStr(pickedRows， "\" & i & "\") = 0 Then            For m = LBound(arrKey) To UBound(arrKey)                key1 = key1 & arr(i， arrKey(m)) & "|"            Next            For j = i + 1 To lastRow                For m = LBound(arrKey) To UBound(arrKey)                    key2 = key2 & arr(j， arrKey(m)) & "|"                Next                If key2 = key1 Then                    pickedRows = pickedRows & "\" & j & "\"                End If                key2 = ""            Next        End If        key1 = ""    Next    '创建 "重叠" 责任表    On Error Resume Next    Set destSheet = ThisWorkbook.Worksheets("重叠")    On Error GoTo 0    If destSheet Is Nothing Then        '创建新的责任表        Set sht = ThisWorkbook.Worksheets.Add        sht.Name = "重叠"        Set destSheet = sht    Else        destSheet.UsedRange.Delete Shift:=xlShiftUp    End If    ws.Rows(1).Copy destSheet.Rows(1)    'destRow = destSheet.UsedRange.Rows.Count + 1    With destSheet        destRow = .Cells(Rows.Count， 1).End(xlUp).Row + 1        firstRow = destRow    End With    For i = lastRow To 2 Step -1        k = InStr(pickedRows， "\" & i & "\")        If InStr(pickedRows， "\" & i & "\") > 0 Then            ws.Rows(i).Copy Destination:=destSheet.Cells(destRow， 1)            destRow = destRow + 1 '            ws.Rows(i).Delete        End If    Next    ws.Activate    MsgBox "得胜删除【" & destRow - firstRow & "】条重叠纪录！"End Sub

4、自定界说表情序列代码（凭证不同数字继承不同表情），凭证重叠的次数不同继承不同的表情：

Function PickColor(index As Integer) As Long    Select Case index    Case 0        PickColor = RGB(255， 255， 0) ' 黄色    Case 1        PickColor = RGB(0， 255， 0) ' 绿色    Case 2        PickColor = RGB(0， 255， 255) ' 青色    Case 3        PickColor = RGB(128， 128， 128) ' 灰色    Case 4        PickColor = RGB(255， 0， 255) ' 紫色    Case 5        PickColor = RGB(0， 0， 255) ' 蓝色    Case 6        PickColor = RGB(255， 128， 0) ' 橙色    Case 7        PickColor = RGB(128， 0， 255) ' 粉色    Case 8        PickColor = RGB(255， 0， 0) ' 红色    Case Else        '若是超出限度，则复返玄色        PickColor = RGB(0， 0， 0) ' 玄色    End SelectEnd Function

5、其他代码

（1）自界说函数：说明无间

Function wContinue(Msg) As Boolean    '说明无间函数    Dim Config As Long    Dim a As Long    Config = vbYesNo + vbQuestion + vbDefaultButton2    Ans = MsgBox(Msg & Chr(10) & Chr(10) & "是(Y)无间?" & Chr(10) & Chr(10) & "否(N)退出！"， Config)    wContinue = Ans = vbYesEnd Function

（2）“删重”按钮：

Private Sub CmdDelete_Click()    Call DeleteDuplicateRecords    Unload MeEnd Sub

（3）“退出”按钮：

Private Sub CmdExit_Click()    Unload MeEnd Sub

（4）“标重”按钮：

Private Sub CmdHighlight_Click()    Call HighlightDuplicateRecords    Unload MeEnd Sub

（5）“全选”按钮：网站建设

Private Sub CmdSelect_Click()    If Me.CmdSelect.Caption = "全选" Then        For i = LBound(arrFields) To UBound(arrFields)            Me.Controls("CheckBox" & i) = True        Next        Me.CmdSelect.Caption = "全消"    Else        For i = LBound(arrFields) To UBound(arrFields)            Me.Controls("CheckBox" & i) = False        Next        Me.CmdSelect.Caption = "全选"    End IfEnd Sub

本站仅提供存储就业，通盘实质均由用户发布，如发现存害或侵权实质，请点击举报。

• 网站建设
• tbTitle