VBA的几个小Demo_2

MergeData

Sub MergeData()
    'ºÏ²¢A¡¢B¡¢C°àMiss
    Dim cc As FileDialog
    
    '´ò¿ª¶Ô»°´°Ñ¡ÔñÏàÓ¦Îļþ
    Set cc = Application.FileDialog(msoFileDialogFilePicker)
    Dim newwork As Workbook
    Set newwork = ThisWorkbook
    
    '¹Ø±ÕÆÁĻˢÐÂ
    Application.ScreenUpdating = False
    With cc
        If .Show = -1 Then
            Dim vrtSelectedItem As Variant
            Dim tempwbrow, xrow As Integer, rng As Range
            For Each vrtSelectedItem In .SelectedItems
                Dim tempwb As Workbook
                Set tempwb = Workbooks.Open(vrtSelectedItem)
                
                '¹Ø±Õ¸öÈËÒþ˽±£»¤
                tempwb.RemovePersonalInformation = False
                
                'ɾ³ýSummaryµÄÄÚÈݲ¢¸´ÖÆ
                xrow = newwork.Worksheets("Summary").Range("A1").CurrentRegion.Rows.Count
                newwork.Worksheets("Summary").Range("A1").Resize(xrow, 5).Delete
                tempwbrow = tempwb.Worksheets("Summary").Range("A1").CurrentRegion.Rows.Count
                tempwb.Worksheets("Summary").Range("A1").Resize(tempwbrow, 5).Copy newwork.Worksheets("Summary").Range("A1")
                
                'ɾ³ýMissµÄÄÚÈݲ¢¸´ÖÆ
                 If xrow <> 1 Then
                    newwork.Worksheets("Miss").Shapes.SelectAll
                    Selection.Delete
                    newwork.Worksheets("Miss").Range("A1").Resize(xrow, 25).Delete
                    tempwb.Worksheets("Miss").Unprotect
                    tempwbrow = tempwb.Worksheets("Miss").Range("A1").CurrentRegion.Rows.Count
                    tempwb.Worksheets("Miss").Range("A1").Resize(tempwbrow, 25).Copy newwork.Worksheets("Miss").Range("A1")
                Else
                    tempwb.Worksheets("Miss").Unprotect
                    tempwbrow = tempwb.Worksheets("Miss").Range("A1").CurrentRegion.Rows.Count
                    tempwb.Worksheets("Miss").Range("A1").Resize(tempwbrow, 25).Copy newwork.Worksheets("Miss").Range("A1")
                End If
                
                'ÐÞ¸ÄMissµÚÒ»ÁÐÓÉÎı¾ÖÁÊý×Ö¸ñʽ
                newwork.Worksheets("Miss").Columns(1).TextToColumns DataType:=xlDelimited, consecutiveDelimiter:=True, Space:=False
                
                'Ð޸ıí¸ñ¿í¶È
                newwork.Worksheets("Miss").Rows.RowHeight = 75
                newwork.Worksheets("Miss").Rows(1).RowHeight = 20
                
                tempwb.Close savechanges:=False
            Next vrtSelectedItem
        End If
    End With
    Set cc = Nothing
    

    
    '¼¤»î¡°ÈËÔ±Missͳ¼Æ¡±¹¤×÷±í
    newwork.Worksheets("ÈËÔ±Missͳ¼Æ").Activate
    
    'Ë¢ÐÂËùÓÐÊý¾Ý
    'ActiveWorkbook.RefreshAll
    
    '¹â±êÒƶ¯ÖÁA1µ¥Ôª¸ñ
    'newwork.Worksheets("ÈËÔ±Missͳ¼Æ").Range("A1").Select
    
    'Òþ²ØÎÞ׼ȷÂÊÈËÔ±£¨ÎÞάÐÞµãÊý£©
    xrow = newwork.Worksheets("ÈËÔ±Missͳ¼Æ").Range("F1").CurrentRegion.Rows.Count
    For Each rng In Range("D1").Resize(xrow, 1)
        If rng.Value < 100 Then
           'Òþ²Ø"Total QTY"Ϊ0µÄÐÐ
           rng.EntireRow.Hidden = True
        Else
           'ÏÔʾ"Total QTY"²»Îª0µÄÐÐ
           rng.EntireRow.Hidden = False
        End If
    Next rng
    
    'Òþ²Ø°à¼¶ÎÞάÐÞµãÊýµÄ±íÍ·£¬Ç°Ò»¸öµ¥Ôª¸ñΪ¸÷°à×ÜάÐÞµãÊýµÄµ¥Ôª¸ñ£¬ºóÒ»µ¥Ôª¸ñΪ¸÷°à¶ÔÓ¦µÄ±íÍ·
    Dim A_rng, B_rng, C_rng As Range
    Set A_rng = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find("A°à")
    Set B_rng = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find("B°à")
    Set C_rng = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find("C°à")
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If A_rng.Offset(0, 2).Value < 10 Then Range("D1").EntireRow.Hidden = True
    If B_rng.Offset(0, 2).Value < 10 Then A_rng.Offset(1, 0).EntireRow.Hidden = True
    If C_rng.Offset(0, 2).Value < 10 Then B_rng.Offset(1, 0).EntireRow.Hidden = True
    

    
    '´ò¿ªÆÁĻˢÐÂ
    Application.ScreenUpdating = True
    
    
End Sub

WeekDaily

Sub WeekDaily():

    Dim i As Integer, n As Range, x As Range
    Dim str, today, day, month, end_month As String
    Application.ScreenUpdating = flase
    
    '''''''''''''''''''''''''±ê¼ÇÐÇÆÚ''''''''''''''''''''''''''
    today = Left(ThisWorkbook.Name, 2) & "/" & Mid(ThisWorkbook.Name, 3, 2)
    str = Application.WorksheetFunction.Text(today, "ddd")
    day = Application.WorksheetFunction.Text(today, "d")
    month = Application.WorksheetFunction.Text(today, "mmm")
    end_month = Application.WorksheetFunction.Text(Application.WorksheetFunction.EoMonth(today, 0), "mm/dd")
    
    
    ''''''''''''''''´¦ÀíÖÜÒ»Êý¾ÝÇ°£¬Çå³ýÉÏÖÜÊý¾Ý'''''''''''''''
    
    If str = "Mon" Then
        ThisWorkbook.Worksheets("Missͳ¼Æ").Rows(2).Find("Mon").Offset(1, 0).Resize(4, 7).ClearContents
        'i = ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Columns(1).Find("Week").CurrentRegion.Rows.Count
        'ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Columns(1).Find("Week").Offset(2, 3).Resize(i - 2, 14).ClearContents
    End If
    
    ''''''''''''''''´¦Àí1ºÅÊý¾ÝÇ°£¬Çå³ýÉÏÖÜÊý¾Ý'''''''''''''''
    If day = "1" Then
        i = ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Rows(1).Find("1").CurrentRegion.Rows.Count
        ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Rows(1).Find("1").Offset(1, 0).Resize(i - 1, 31).ClearContents
        'ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Range("B1") = month
    End If
    
    ''''''''''''''''''''¸´ÖÆ׼ȷÂÊÖÁTrend'''''''''''''''''''''''
    
    Dim rng(3) As Range
    Set rng(1) = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find("A°à")
    Set rng(2) = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find("B°à")
    Set rng(3) = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find("C°à")
    
    ThisWorkbook.Worksheets("Missͳ¼Æ").Rows(2).Find(str).Offset(1, 0).Resize(4, 1).ClearContents
    For i = 1 To 3
        If rng(i).Offset(0, 2).Value >= 100 Then
            ThisWorkbook.Worksheets("Missͳ¼Æ").Rows(2).Find(str).Offset(i, 0) = rng(i).Offset(0, 4).Value
        End If
    Next
    
    ThisWorkbook.Worksheets("Missͳ¼Æ").Rows(2).Find(str).Offset(4, 0).FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)"
    
    ''''''''''''''''''''ÈÕ׼ȷÂʸ´ÖÆÖÁÖÜ׼ȷÂÊ''''''''''''''''''
    i = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Range("A1").CurrentRegion.Rows.Count
    ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Range("F1").Resize(i, 1).Copy
    ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Rows(1).Find(day).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    
    '''''''''''''''''''''''ÔÂ׼ȷÂʸ´ÖÆÖÁ¸÷ÔÂ''''''''''''''''''''
    If today = end_month Then
        If month = "Jan" Then
            i = ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Rows(1).Find("Jan").CurrentRegion.Rows.Count
            ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Rows(1).Find("Jan").Offset(1, 0).Resize(i - 1, 12).ClearContents
        End If
        
        i = ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Rows(1).Find("AVE").CurrentRegion.Rows.Count - 1
        ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Rows(1).Find("AVE").Offset(1, 0).Resize(i, 1).Copy
        ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Rows(1).Find(month).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
        
    End If
    
    
    
    ''''''''''''''''''''''QTY¸´ÖÆÖÁÖÜ׼ȷÂÊ''''''''''''''''''''''

    'i = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Range("A1").CurrentRegion.Rows.Count
    'ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Range("D1").Resize(i, 2).Copy
    'ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Rows(ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Columns(1).Find("Week").Row).Find(str).Offset(1, 0).PasteSpecial Paste:=xlPasteValues


    '''''''''''''''ÖÜÈÕ¸´ÖÆÖÜƽ¾ù׼ȷÂÊÖÁ׼ȷÂÊͳ¼Æ±í'''''''''''''
    'If str = "Sun" Then
        'i = ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Columns(1).Find("Week").CurrentRegion.Rows.Count - 1
        'ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Columns(1).Find("Week").Offset(1, 19).Resize(i, 1).Copy
        'Set x = ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Range("A2")
        'Do While x <> ""
        'Set x = x.Offset(0, 1)
        'Loop
        'x.PasteSpecial Paste:=xlPasteValues
    'End If
    
    
    ''''''''''''''''''¸Ä±äÊý¾ÝchartÑÕÉ«'''''''''''''''''''''''''''
    Dim m, y As Integer
    For i = 1 To 3
    ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").ChartObjects(i).Activate


    If ActiveChart.SeriesCollection.Count <> 0 Then
        ActiveChart.SeriesCollection(1).DataLabels.Delete
        ActiveChart.SeriesCollection(1).ApplyDataLabels
        y = ActiveChart.SeriesCollection(1).Points.Count
        For m = 1 To y
            ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").ChartObjects(i).Activate
            ActiveChart.SeriesCollection(1).Points(m).DataLabel.Select
            If m <> y Then
                With Selection.Format.TextFrame2.TextRange.Font
                    .Fill.ForeColor.RGB = RGB(0, 0, 0)
                    .Bold = msoFlase
                End With
            Else
                With Selection.Format.TextFrame2.TextRange.Font
                    .Fill.ForeColor.RGB = RGB(0, 176, 80)
                    .Bold = msoTrue
                End With
            End If
         Next
    End If
    Next
    
    '''''''''''''''''''''''''''´ò¿ªÆÁÄ»¸üÐÂ''''''''''''''''''''''''''''''''''
    Application.ScreenUpdating = flase
    
    ''''''''''''''''''''''''''END'''''''''''''''''''''''''''''''''''
    
End Sub

End_Daily

Sub End_Daily()
'¸´ÖÆͼ±íÖÁ¡±»ã×Ü¡°²¢ð¤ÌùΪͼƬ

    Dim r, g As Range, x, y As Integer
    Dim str, layer, Miss_OP, Miss_Layer As String
    Dim shp As Shape
    Dim m, wid, hig As Integer
    
    '''''''''''''''''''''''''´ò¿ªÆÁÄ»ÏÔʾ'''''''''''''''''''''
    
    Application.ScreenUpdating = False
    
    
    '''''''''''''''''''''''''±ê¼ÇÈÕÆÚ'''''''''''''''''''''''''
    
    str = Application.WorksheetFunction.Text(Left(ThisWorkbook.Name, 2) & "/" & Mid(ThisWorkbook.Name, 3, 2), "mm/dd")
    
    ''''''''''''''''''''''  ±ê¼Ç¸´ÅÐĤ²ã''''''''''''''''''''''
    
    Set r = ThisWorkbook.Worksheets("Missͳ¼Æ").Rows(2).Find("Total QTY")
    layer = ""
    r.Offset(1, 2).Resize(5, 1).ClearContents
    For i = 1 To 5
        If r.Offset(i, 0) > 10 Then
            layer = layer & r.Offset(i, -1) & "¡¢"
            r.Offset(i, 2).FormulaR1C1 = "= 1- RC[-1]/RC[-2]"
        End If
    Next
    If layer <> "" Then
        layer = Left(layer, Len(layer) - 1)
    End If
        
    
    '''''''''''''''''''''''''Ð޸ıíÍ·''''''''''''''''''''''''''
    
    ThisWorkbook.Worksheets("»ã×Ü").Range("A2").Value = "BP ÖÆÔ첿 ¼ì²â¿Æ Repair Miss Daily Report£¨" & str & "£©"
    
    ''''''''''''''''''''''' Ð޸ĸ´ÅÐĤ²ã''''''''''''''''''''''''''
    
    ThisWorkbook.Worksheets("»ã×Ü").Range("A9").Value = "Èý¡¢×¼È·ÂÊÊä³ö¡¾¸´ÅÐĤ²ã£º" & layer & "¡¿"
    
    
    ''''''''''''''''''''''¼¤»î»ã×ܹ¤×÷±í'''''''''''''''''''''''
    
    ThisWorkbook.Worksheets("»ã×Ü").Activate

    '''''''''''''''''''''ɾ³ý"»ã×Ü"ÖÐÎÞÓÃͼƬ'''''''''''''''''
    
    For Each shp In Worksheets("»ã×Ü").Shapes
        If shp.Type <> msoChart And shp.Type <> msoFormControl Then shp.Delete
    Next
    
    '''''''''''''''''''¸´ÖÆ "Miss ͳ¼Æ"ÖÁÊ×Ò³"'''''''''''''''''
    
    Set r = ThisWorkbook.Worksheets("Missͳ¼Æ").Rows(2).Find("Sun").Offset(4, 0)
    ThisWorkbook.Worksheets("Missͳ¼Æ").Range("A1").Resize(r.Row, r.Column).CopyPicture
    ThisWorkbook.Worksheets("»ã×Ü").Range("A5").Select
    wid = Selection.Width
    hig = Selection.Height
    ThisWorkbook.Worksheets("»ã×Ü").Paste Destination:=Worksheets("»ã×Ü").Range("A5")
    With Selection.ShapeRange
        .LockAspectRatio = msoFalse
        .Height = hig - 2
        .Width = wid - 2
        .IncrementLeft 1.5
        .IncrementTop 1.5
    End With
    
    ''''''''''''''''''¸´ÖÆ "ÈËÔ±Missͳ¼Æ"ÖÁÊ×Ò³"''''''''''''''''
    
    Dim rng(3) As Range
    Set rng(1) = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find("A°à")
    Set rng(2) = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find("B°à")
    Set rng(3) = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find("C°à")
    
    x = 0
    For i = 1 To 3
        If rng(i).EntireRow.Hidden = 0 And rng(i).Offset(0, 2).Value >= 100 Then
            x = x + 1
            m = 0
            
            '''''''''''''''''''''''''''Ð޸ıíÍ·'''''''''''''''''''''''''''''''''
            
            ThisWorkbook.Worksheets("»ã×Ü").Cells(10 + 4 * (x - 1), 1).Value = x & "¡¢" & rng(i) & "׼ȷÂÊ"
            
            '''''''''''''''''''''''''''ͼƬ¸´ÖÆ'''''''''''''''''''''''''''''''''
            
            If i <> 1 Then
                m = rng(i).Row - rng(i - 1).Row
            Else
               m = rng(i).Row
            End If
                rng(i).Offset(-1 * (m - 1), -1).Resize(m, 13).CopyPicture
                ThisWorkbook.Worksheets("»ã×Ü").Cells(11 + 4 * (x - 1), 1).RowHeight = rng(i).Height * rng(i).Offset(0, -1)
                ThisWorkbook.Worksheets("»ã×Ü").Cells(11 + 4 * (x - 1), 1).Select
                wid = Selection.Width
                hig = Selection.Height
                ThisWorkbook.Worksheets("»ã×Ü").Paste Destination:=Worksheets("»ã×Ü").Cells(11 + 4 * (x - 1), 1)
                With Selection.ShapeRange
                    .LockAspectRatio = msoFalse
                    .Width = wid - 2
                    .Height = hig - 2
                    .IncrementLeft 1.2
                    .IncrementTop 1.5
                End With
            Application.CutCopyMode = False
            
            
            '''''''''''''''''''''''''°à×é/ÈËÔ±ÄÜÁ¦·ÖÎö''''''''''''''''''''''''''''
            
            Dim row_OPmiss, p_OPmiss, qty_OPmiss As Integer, rng_OPmiss As Range
            
            '''''''''''''''''''''''''ˢи½¼þÊý¾Ý͸ÊÓ±í''''''''''''''''''''''''''
            
            Worksheets("¸½¼þ").PivotTables("Êý¾Ý͸ÊÓ±í1").PivotCache.Refresh
            
            row_OPmiss = ThisWorkbook.Worksheets("¸½¼þ").Range("A1").CurrentRegion.Rows.Count
            Miss_OP = ""
            qty_OPmiss = 0
            
            For Each rng_OPmiss In rng(i).Offset(-1 * (m - 2), 3).Resize(m - 2, 1)
                If rng_OPmiss.Value > 0 Then
                    qty_OPmiss = qty_OPmiss + 1
                    'MsgBox rng_OPmiss.Offset(0, -3).Value
                    Miss_OP = Miss_OP & rng_OPmiss.Offset(0, -2) & "MissΪ"
                    For p_OPmiss = 1 To row_OPmiss
                        'MsgBox ThisWorkbook.Worksheets("¸½¼þ").Cells(p_OPmiss, 1).Value
                        If ThisWorkbook.Worksheets("¸½¼þ").Cells(p_OPmiss, 1).Value = rng_OPmiss.Offset(0, -3).Value Then
                            If ThisWorkbook.Worksheets("¸½¼þ").Cells(p_OPmiss, 2).Value <> "GA2¿×Remainδ°µµã»¯" Then
                            Miss_OP = Miss_OP & Left(ThisWorkbook.Worksheets("¸½¼þ").Cells(p_OPmiss, 3), 3) & " " & ThisWorkbook.Worksheets("¸½¼þ").Cells(p_OPmiss, 2).Value & "£»"
                            Else
                            Miss_OP = Miss_OP & ThisWorkbook.Worksheets("¸½¼þ").Cells(p_OPmiss, 2).Value & "£»"
                            End If
                        End If
                    Next
                    Miss_OP = Miss_OP & Chr(10)
                End If
                
            Next
            If Miss_OP <> "" Then
                ThisWorkbook.Worksheets("»ã×Ü").Cells(13 + 4 * (x - 1), 1).Value = Miss_OP
                ThisWorkbook.Worksheets("»ã×Ü").Cells(13 + 4 * (x - 1), 1).RowHeight = 17 * qty_OPmiss
            Else
                ThisWorkbook.Worksheets("»ã×Ü").Cells(13 + 4 * (x - 1), 1).Value = "ÎÞ ;"
                ThisWorkbook.Worksheets("»ã×Ü").Cells(13 + 4 * (x - 1), 1).RowHeight = 16
            End If
        End If
     Next
    
    '''''''''''''''''''''''¸ß·¢Miss·ÖÎö''''''''''''''''''''''''
    
    ThisWorkbook.Worksheets("»ã×Ü").Range("A19").Resize(1, 8).ClearContents
    
    x = ThisWorkbook.Worksheets("Missͳ¼Æ").Rows(2).Find("Rank").CurrentRegion.Rows.Count - 1

    For i = 1 To 4
        For Each r In ThisWorkbook.Worksheets("Missͳ¼Æ").Rows(2).Find("Rank").Resize(x, 1)
            If r = i And r.Offset(0, -1).Value > 0 Then
                ThisWorkbook.Worksheets("»ã×Ü").Cells(19, 2 * (i - 1) + 1) = r.Offset(0, -2)
                With ThisWorkbook.Worksheets("Miss")
                    m = .Rows(1).Find("Description").Column
                    .Columns(m).Find(r.Offset(0, -2)).Offset(0, -5).Resize(1, 2).Copy ThisWorkbook.Worksheets("»ã×Ü").Cells(20, 2 * (i - 1) + 1)
                
                End With
                
                Exit For
            End If
            
        Next
    Next
    '''''''''''''''''''''''Çå³ýͼƬÇøÓò¸ñʽ'''''''''''''''''''''
    
    'ThisWorkbook.Worksheets("»ã×Ü").Range("A20:H20").Interior.ThemeColor = xlThemeColorDark1
    ThisWorkbook.Worksheets("»ã×Ü").Range("A20:H20").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    
    ''''''''''''''''''''''''´ò¿ªÆÁÄ»ÏÔʾ''''''''''''''''''''''''
   
    Application.ScreenUpdating = True
    
End Sub

J0_Delete

Sub J0_Delete()

Dim qty_Miss, i, col As Integer
Dim rng As Range
Dim str As String
qty_Miss = ThisWorkbook.Worksheets("Miss").Range("A1").CurrentRegion.Rows.Count

With ThisWorkbook.Worksheets("Miss")
    col = .Rows(1).Find("Description").Column
    str = ""
    For i = 2 To qty_Miss
       If .Cells(i, col).Value = "½ÌÓý" Then
            Set rng = ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Columns(2).Find(.Cells(i, 1).Value)
            If rng Is Nothing Then
                str = str + " " + CStr(.Cells(i, 1))
                .Cells(i, 1).Value = "OP_ID " + CStr(.Cells(i, 1))
            Else:
                .Cells(i, 1).Value = rng.Offset(0, 1)
            End If
            .Cells(i, 2).ClearContents
            .Cells(i, col - 1).ClearContents
            .Cells(i, col).ClearContents
       End If
    Next
    If str <> "" Then
        MsgBox (str + "δÕÒµ½")
    End If
End With

End Sub
    

Delete&Add_OP_ID

Sub Delete_OP_ID()
    Dim i As Integer
    Dim str As String
    Dim rng1, rang2 As Range
    Application.ScreenUpdating = False
    i = 3
    Do While ThisWorkbook.Worksheets("¸½¼þ").Cells(i, 13) <> ""
        str = ThisWorkbook.Worksheets("¸½¼þ").Cells(i, 13).Value
        Set rng1 = ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Columns(2).Find(str)
        Set rng2 = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find(str)
        If rng1 Is Nothing Or rng2 Is Nothing Then
            MsgBox (str + " No Found")
            Exit Sub
        Else
            rng1.EntireRow.Delete shift:=xlUp
            rng2.EntireRow.Delete shift:=xlUp
        End If
        ThisWorkbook.Worksheets("¸½¼þ").Cells(i, 12).Resize(1, 3).Delete shift:=xlUp
        'i = i + 1
    Loop
    ThisWorkbook.Worksheets("¸½¼þ").Activate
    Application.ScreenUpdating = True
End Sub
Sub Add_OP_ID()
    Dim i As Integer
    Dim str As String
    Dim rng1, rang2 As Range
    Application.ScreenUpdating = False
    i = 3
    Do While ThisWorkbook.Worksheets("¸½¼þ").Cells(i, 17) <> ""
        str = ThisWorkbook.Worksheets("¸½¼þ").Cells(i, 17).Value
        Set rng1 = ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Columns(2).Find(str)
        Set rng2 = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find(str)
        If rng1 Is Nothing Or rng2 Is Nothing Then
            str = ThisWorkbook.Worksheets("¸½¼þ").Cells(i, 16).Value
            Set rng1 = ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Columns(2).Find(str).Offset(-1, 0)
            Set rng2 = ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Columns(2).Find(str).Offset(-1, 0)
            ThisWorkbook.Worksheets("ÖÜ׼ȷÂÊ").Rows(rng1.Row).Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            ThisWorkbook.Worksheets("ÈËÔ±Missͳ¼Æ").Rows(rng2.Row).Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            ThisWorkbook.Worksheets("¸½¼þ").Cells(i, 16).Resize(1, 3).Copy
            rng1.Offset(-1, -1).PasteSpecial Paste:=xlPasteValues
            rng2.Offset(-1, -1).PasteSpecial Paste:=xlPasteValues
            rng1.Offset(0, 33).AutoFill Destination:=rng1.Offset(-1, 33).Resize(2, 1), Type:=xlFillDefault
            rng2.Offset(0, 2).Resize(1, 4).AutoFill Destination:=rng2.Offset(-1, 2).Resize(2, 4), Type:=xlFillDefault
        Else
            MsgBox (str + " Is Exist")
            Exit Sub
        End If
        ThisWorkbook.Worksheets("¸½¼þ").Cells(i, 16).Resize(1, 3).Delete shift:=xlUp
        'i = i + 1
    Loop
    ThisWorkbook.Worksheets("¸½¼þ").Activate
    Application.ScreenUpdating = True
End Sub

绩效和对

Sub ¼¨Ð§ºË¶Ô()
    
    Dim newwork, oldwork As Workbook
    Dim repair_Count, i, j, x1, x2, y1, y2 As Integer
    Dim x, y As Integer
        
    Set oldwork = ThisWorkbook
    
    Filename = Application.GetOpenFilename("Excel Îļþ ,*.xls;*.xlsx")
    
    If Filename <> False Then
    
        Set newwork = Workbooks.Open(Filename)
        repair_Count = Application.WorksheetFunction.CountIf(newwork.Worksheets("׼ȷÂÊ").Range("E:E"), "Repair")
        flag = newwork.Worksheets("׼ȷÂÊ").Columns("E").Find("Repair").Row
        
        For x = flag To flag + repair_Count - 1
            For y = 1 To 31
                x1 = x
                y1 = newwork.Worksheets("׼ȷÂÊ").Rows(2).Find(y).Column
                
                
                x2 = oldwork.Worksheets("ÖÜ׼ȷÂÊ").Columns(2).Find(newwork.Worksheets("׼ȷÂÊ").Cells(x1, 2)).Row
                y2 = oldwork.Worksheets("ÖÜ׼ȷÂÊ").Rows(1).Find(y).Column
                
                If newwork.Worksheets("׼ȷÂÊ").Cells(x1, y1) <> oldwork.Worksheets("ÖÜ׼ȷÂÊ").Cells(x2, y2) Then
                    With oldwork.Worksheets("ÖÜ׼ȷÂÊ").Cells(x2, y2)
                            .FormatConditions.Delete
                            .Font.Color = -16776961
                            .Font.Bold = True
                    End With
                End If
            Next
        Next
        
        newwork.Close savechanges:=False
    End If
    
End Sub

Sub Email()
    Application.ScreenUpdating = False
    Dim shp As Shape
    For Each shp In Sheets("Miss").Shapes
        shp.Delete
    Next
    Sheets("»ã×Ü").Range("A2:H22").Copy
    Sheets("»ã×Ü").Range("K1").Select
    Sheets("»ã×Ü").Pictures.Paste.Select
    Selection.Cut
    ThisWorkbook.Close savechanges:=True
    Application.ScreenUpdating = False
End Sub