VBA将原始工作簿的格式粘贴到新的工作簿

Question

我希望你能提供帮助。我有下面的代码。它基本上是做什么的，它打开一个对话框，允许用户选择一个Excel工作表，然后出口到国家栏（11）对其进行过滤，然后将该国家复制并粘贴到一个新的工作簿中，命名为新的工作簿该国然后重复下一个国家的行动，然后保存并关闭每个工作簿。

的代码完美的作品，它只是不会复制并粘贴原始格式。我似乎无法获得代码中的特殊粘贴区域。我在下面添加了图片来显示不同之处。

我只是想知道如果我下面的代码可以被改变，以保持原有的

原始格式

粘贴格式的外观和格式

我的代码

Sub Open_Workbook_Dialog() 

Dim my_FileName As Variant 
Dim my_Workbook As Workbook 

    MsgBox "Pick your CRO file" '<--| txt box for prompt to pick a file 

    my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection 

    If my_FileName <> False Then 
    Set my_Workbook = Workbooks.Open(Filename:=my_FileName) 



    Call Filter(my_Workbook) '<--|Calls the Filter Code and executes 

    End If 
End Sub 

Public Sub Filter(my_Workbook As Workbook) 
    Dim rCountry As Range, helpCol As Range 
    Dim wb As Workbook 
    With my_Workbook.Sheets(1) '<--| refer to data worksheet 
    With .UsedRange 
     Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in 
    End With 

    With .Range("A1:Y" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Y" from row 1 to last non empty row of column "A" 
      .Columns(11).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 11th column of the referenced range and store its unique values in "helper" column 
      Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row) 
      For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row) 
       .AutoFilter 11, rCountry.Value2 '<--| filter data on country field (11th column) with current unique country name 
       If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered... 
        Set wb = Application.Workbooks.Add '<--... add new Workbook 
         wb.SaveAs Filename:=rCountry.Value2 '<--... saves the workbook after the country 
          .SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Range("A1") 
         ActiveSheet.Name = rCountry.Value2 '<--... rename it 
        .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header 
        wb.Close SaveChanges:=True '<--... saves and closes workbook 
       End If 
      Next 
     End With 
     .AutoFilterMode = False '<--| remove autofilter and show all rows back 
    End With 
    helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included) 
End Sub 

Answer 1

你可以做一个额外的“模板”片原始工作簿中，这将被格式化为源表。然后，将过滤的数据复制到模板表中，并将模板表复制为新的工作簿。 唯一的问题是，如果您更改源表格的格式，则必须在模板表中执行相同的操作。

Answer 2

通常情况下，当我需要的小宏做一些我犹豫如何实现，我用Excel的宏录制功能。在你的情况下，我会开始录制，转到源表单，选择并复制范围，转到目标表单，点击PASTE应该启动的单元格，粘贴，停止录制。

然后，而在开发模式中，你会发现产生的宏，你可以更新到您的需求完全符合。

此方法总是为我工作。希望它也适合你。

Answer 3

我发现这段代码和插入它在之前的保存并关闭其做工精细

Columns("A:B").Select 

Selection.EntireColumn.AutoFit 

的地方，哪里就有奇迹

.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header 
        Columns("A:Y").Select 
        Selection.EntireColumn.AutoFit 
       wb.Close SaveChanges:=True '<--... saves and closes workbook