求助如何匹配数据格式

prowl

请教：以sheet1的A列内容为依据，将sheet1的格式与sheet2的格式匹配，如果两个sheet中A列内容一致，，则在sheet2的相同行显示sheet1的相同格式。

3190496160

相同格式？？？？是指单元格填充颜色吗？？？？

longwin

Sub test()
arr = Sheets("Sheet2").[a1].CurrentRegion
Set sh = Sheets("Sheet1")
For i = 1 To UBound(arr)
    If arr(i, 1) = sh.Cells(i, 1) Then
        sh.Cells(i, 1).Copy Sheets("Sheet2").Cells(i, 1)
    End If
Next

End Sub

prowl

longwin 发表于 2024-7-20 10:13
Sub test()
arr = Sheets("Sheet2").[a1].CurrentRegion
Set sh = Sheets("Sheet1")

感谢老师的解答

prowl

3190496160 发表于 2024-7-20 10:08
相同格式？？？？是指单元格填充颜色吗？？？？

就是，希望sheet1的A列内容和sheet2的A列内容是一样的，那么sheet1A列那一整行的格式就复制到sheet2A列的一整行

prowl

prowl 发表于 2024-7-20 13:10
就是，希望sheet1的A列内容和sheet2的A列内容是一样的，那么sheet1A列那一整行的格式就复制到sheet2A列的 ...

比如sheet1第8行和sheet2第6行的A6都是213，那么sheet1A8一行是绿色的，就把这一行绿色的复制到sheet2中的A6那一行

3190496160

Sub 匹配格式()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set sh = Sheet1
With sh
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "sheet1为空！": End
    ar = .Range("a1:a" & r)
    For i = 1 To UBound(ar)
        If ar(i, 1) <> "" Then
            d(ar(i, 1)) = i
        End If
    Next i
End With
With Sheet2
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs < 2 Then MsgBox "sheet2为空！": End
    ar = .Range("a1:a" & r)
    For i = 1 To UBound(ar)
        If ar(i, 1) <> "" Then
            xh = d(ar(i, 1))
            If xh <> "" Then
                sh.Rows(xh).Copy
                .Rows(i).PasteSpecial Paste:=xlPasteFormats
            End If
        End If
    Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

格式匹配.rar (15.04 KB, 下载次数: 9)

2024-7-21 08:56 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&
   
    Application.ScreenUpdating = False
    br = Worksheets(1).[A1].CurrentRegion.Value
   
    Cells.Interior.Color = xlNone
    With [A1].CurrentRegion
        ar = .Value
        For i = 1 To UBound(ar)
            For j = 1 To UBound(br)
                If br(j, 1) = ar(i, 1) Then
                    Worksheets(1).Cells(j, 1).EntireRow.Copy .Cells(i, 1)
                    Exit For
                End If
            Next j
        Next i
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。。。。