利用VBA筛选关键词后复制内容到另一张表，保持文本格式的数字格式不变

dlmuxqh

按：筛选词 工作表里的筛选词，把本工作薄中A列包含筛选词的所在行复制到新工作表，新工作表以“特殊”命名，此功能已经实现，但是有一个问题，复制到“特殊”工作表后，原表中联系电话一栏格式发生变化，怎样才能保持不变呢？即，筛选后生成的“特殊”工作表中的联系电话一栏中的电话也需要以文本形式保存，格式保持一致。代码与附件已经放在下方，麻烦各位大佬帮忙解决一下。谢谢！

Sub xjc()
    Dim arr, brr, sht As Worksheet, i, j&, k&
    Dim d As Object
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("筛选词").[a1].CurrentRegion
    With Sheets("数据")
    brr = .[a1].CurrentRegion
    End With
    ReDim crr(1 To UBound(brr), 1 To UBound(brr, 2))
        For n = 2 To UBound(arr)
            For i = 2 To UBound(brr)
                If InStr(brr(i, 1), arr(n, 1)) Then
                    k = k + 1
                    For c = 1 To UBound(brr, 2)
                        crr(k, c) = brr(i, c)
                    Next
                End If
            Next
        Next
    Set sht = Sheets.Add(, Sheets(Sheets.Count))
    sht.Name = "特殊"
    sht.[a1].Resize(UBound(crr), UBound(crr, 2)) = crr
    MsgBox "OK"
    Set d = Nothing
    Application.ScreenUpdating = True
End Sub

chaohuahch

    sht.Name = "特殊"
    sht.[a1].Resize(UBound(crr), UBound(crr, 2)) = crr
    Columns("B:B").EntireColumn.AutoFit
    MsgBox "OK"
加上一句代码
你可以试一试，是你要的效果嘛？

lsc900707

单元格格式没变，只是列宽的问题，加一句代码就行：
    Set sht = Sheets.Add(, Sheets(Sheets.Count))
    sht.Name = "特殊"
    sht.[a1].Resize(UBound(crr), UBound(crr, 2)) = crr
    Cells.EntireColumn.AutoFit

dlmuxqh

chaohuahch 发表于 2018-7-12 15:50
sht.Name = "特殊"
    sht.[a1].Resize(UBound(crr), UBound(crr, 2)) = crr
    Columns("B:B").En ...

你好，是好使的，但是我现在有另外一个表，表中数据可能较多，然后加上这句代码也不太好使，我上传了一个附件，您能帮忙看一下吗？谢谢！
代码如下：
Sub o0select()
Dim arr, brr, sht As Worksheet, I, j&, k&
    Dim d As Object
    On Error Resume Next
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("0O").[a1].CurrentRegion
    With Sheets("2非成品油订单1.1零点至5.3的23.59.59未开增票导出")
    brr = .[a1].CurrentRegion
    End With
    ReDim crr(1 To UBound(brr), 1 To UBound(brr, 2))
        For n = 1 To UBound(arr)
            For I = 1 To UBound(brr)
                If InStr(brr(I, 2), arr(n, 1)) Then
                    k = k + 1
                    For c = 1 To UBound(brr, 2)
                        crr(k, c) = brr(I, c)
                    Next
               End If
            Next
        Next
    Set sht = Sheets.Add(, Sheets(Sheets.Count))
    sht.Name = "0O列表"
    sht.[a1].Resize(k, UBound(brr, 2)) = crr
    Columns("A:U").EntireColumn.AutoFit

    '格式刷
    Sheets("2非成品油订单1.1零点至5.3的23.59.59未开增票导出").Select
    Cells.Select
    Selection.Copy
    Sheets("0O列表").Select
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False


    MsgBox "OK"
    Set d = Nothing
    Application.ScreenUpdating = True
End Sub

dlmuxqh

lsc900707 发表于 2018-7-12 16:09
单元格格式没变，只是列宽的问题，加一句代码就行：
    Set sht = Sheets.Add(, Sheets(Sheets.Count))
...

你好，是好使的，但是我现在有另外一个表，表中数据可能较多，然后加上这句代码就不太好使，我上传了一个附件，您能帮忙看一下吗？
这个新附件主要是T列和U列

谢谢！
代码如下：
Sub o0select()
Dim arr, brr, sht As Worksheet, I, j&, k&
    Dim d As Object
    On Error Resume Next
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("0O").[a1].CurrentRegion
    With Sheets("2非成品油订单1.1零点至5.3的23.59.59未开增票导出")
    brr = .[a1].CurrentRegion
    End With
    ReDim crr(1 To UBound(brr), 1 To UBound(brr, 2))
        For n = 1 To UBound(arr)
            For I = 1 To UBound(brr)
                If InStr(brr(I, 2), arr(n, 1)) Then
                    k = k + 1
                    For c = 1 To UBound(brr, 2)
                        crr(k, c) = brr(I, c)
                    Next
               End If
            Next
        Next
    Set sht = Sheets.Add(, Sheets(Sheets.Count))
    sht.Name = "0O列表"
    sht.[a1].Resize(k, UBound(brr, 2)) = crr

    '格式刷
    Sheets("2非成品油订单1.1零点至5.3的23.59.59未开增票导出").Select
    Cells.Select
    Selection.Copy
    Sheets("0O列表").Select
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
      
    MsgBox "OK"
    Set d = Nothing
    Application.ScreenUpdating = True
End Sub

dlmuxqh

chaohuahch 发表于 2018-7-12 15:50
sht.Name = "特殊"
    sht.[a1].Resize(UBound(crr), UBound(crr, 2)) = crr
    Columns("B:B").En ...

主要是T列和U列

chaohuahch

dlmuxqh 发表于 2018-7-12 16:17
你好，是好使的，但是我现在有另外一个表，表中数据可能较多，然后加上这句代码也不太好使，我上传了一个 ...

    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
      
修改成
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False

dlmuxqh

chaohuahch 发表于 2018-7-12 17:09
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, ...

我试了一下，好像不太对哦，我下面这段是格式刷的部分，如果改成Paste:=xlPasteAllUsingSourceTheme，那我那个新生成的表中就不仅仅是关键词所代表的行，而是原始表中所有数据都被粘贴过来了~
不过还是谢谢您哦

dlmuxqh

chaohuahch 发表于 2018-7-12 17:09
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, ...

好像不太对，修改之后，新生成的表中就不是关键词代表的行，而是原始表中所有的行了~不过还是谢谢你啦~