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