ソースフォーマットでExcelデータをコピー

Question

これを行うためにマクロを記録し、マクロコードをコピーして、それを必要に応じて調整しました。しかし、私の問題は、新しいワークシートに貼り付けたときにソースの書式設定が保持されないということです。私は何のステップを逃したのですか？それはSelection.PasteSpecialの権利と関係があるはずですか？以下は、非稼働構文

Selection.AutoFilter 
ActiveSheet.ListObjects("db1.accdb").Range.AutoFilter Field:=1, Criteria1:="Pink" 
For LastRow = 2 To Worksheets("Sheet2").Range("A65536").End(xlUp).Row 
    Next LastRow 
Range("A1", "M" & LastRow).Copy 
Sheets.Add After:=ActiveSheet 
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
Range("A1").Select 
ActiveSheet.Name = "Pink" 

Answer 1

Selection.PasteSpecialの必要がない、通常のCopy方法は十分ではないです。

Sub copyTest() 

    '/ Source    Destination 
    '--------    ----------- 
    Sheet1.UsedRange.Copy Sheet2.Cells(1, 1) 
    Application.CutCopyMode = False 

End Sub 

< < - このはあなたのコードのために動作します>>

Sub Test() 

    Dim LastRow  As Long 
    Dim rngCopy  As Range 


    Selection.AutoFilter 
    ActiveSheet.ListObjects("db1.accdb").AutoFilter Field:=1, Criteria1:="Pink" 

    Set rngCopy = ActiveSheet.UsedRange 

    '/ Get rid of headers 
    Set rngCopy = rngCopy.Offset(1).Resize(rngCopy.Rows.Count - 1) 


    Set rngCopy = rngCopy.SpecialCells(XlCellType.xlCellTypeVisible) 



    ThisWorkbook.Worksheets.Add after:=ActiveSheet 
    ActiveSheet.Name = "Pink" 

    rngCopy.Copy ThisWorkbook.Worksheets("Pink").Cells(1, 1) 
    Application.CutCopyMode = False 

End Sub 

Answer 2

以下のコードを試してみてください。

を1.UsingはなくActiveSheetの、オブジェクトを参照しました。

2.最後にコード実行中にAutoFilterが適用された場合はチェックします。そうでない場合は、適用された場合にシートの面積がすでにフィルタリングされたときには、お住まいの地域からフィルタを削除し、使用しようとしたときには、エラー行を取得する： Sht.ListObjects("db1.accdb").Range.AutoFilter Field:=1, Criteria1:="Pink"

完全なコード：

Option Explicit 

Sub CopyFilteredObject() 

Dim LastRow As Long 
Dim Sht  As Worksheet 
Dim DestSht As Worksheet 

' better avoiding ActiveSheet >> use your sheet's name 
Set Sht = ActiveSheet ' use Sheets("Sheet1") for example 

' check if auto-filer is applied, if yes don't remove it by using AutoFilter again 
If Sht.AutoFilter.FilterMode = False Then 
    Selection.AutoFilter 
End If 

Sht.ListObjects("db1.accdb").Range.AutoFilter Field:=1, Criteria1:="Pink" 

' find last row 
LastRow = Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row 

' set destination sheet after current sheet 
Set DestSht = Sheets.Add(after:=Sht) 
DestSht.Name = "Pink" 

Sht.Range("A1:M" & LastRow).Copy 
DestSht.Cells.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 

DestSht.Range("A1").Select 

End Sub