VBA zum Einfügen Format von Original Workbook zu neuen Arbeitsbuch

Question

Ich hoffe, Sie können helfen. Ich habe den Code unten. Im Wesentlichen öffnet es ein Dialogfeld, in dem ein Benutzer ein Excel-Blatt auswählen kann, dann wird es in die Länderspalte (11) ausgefiltert, kopiert und fügt dann dieses Land in eine neue Arbeitsmappe ein und benennt die neue Arbeitsmappe danach Dieses Land wiederholt dann die Aktion für das nächste Land, speichert und schließt dann jedes Arbeitsbuch.

Der Code funktioniert perfekt, es kopiert nicht einfach das Originalformat. Ich scheine nicht in der Lage zu sein, den speziellen Einfügebereich in den Code zu bekommen. Ich habe Bild unten hinzugefügt, um den Unterschied zu zeigen.

Ich frage mich, ob mein Code unten verändert werden, um das Aussehen und die Formatierung des Original

Originalformat

Pasted Format

zu halten MEIN CODE

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

Sie könnten in der ursprünglichen Arbeitsmappe ein weiteres "Vorlagen" -Blatt erstellen, das als Quellblatt formatiert wird. Anschließend kopieren Sie die gefilterten Daten in das Vorlagenblatt und kopieren das Vorlagenblatt als neue Arbeitsmappe. Das einzige Problem ist, dass Sie, wenn Sie die Formatierung Ihres Quelldatenblatts ändern, dasselbe im Vorlagenblatt tun müssten.

Answer 2

Normalerweise, wenn ich s kleines MACRO brauche, um etwas zu tun, zögere ich zu implementieren, ich benutze die MACRO RECORDING-Funktion von Excel. In meinem Fall würde ich die Aufnahme starten, zum Quellblatt gehen, den Bereich auswählen und kopieren, zum Zielblatt gehen, auf die Zelle klicken, in die die PASTE starten soll, Einfügen, Aufzeichnung stoppen.

Im Entwicklermodus finden Sie dann das generierte Makro, das Sie aktualisieren können, damit es Ihren Anforderungen entspricht.

Diese Methode funktionierte IMMER für mich. Hoffe es tut es auch für dich.

Answer 3

fand ich dieses Stück Code und steckte es in kurz vor dem Speichern und schließen und seine adaequat

Columns("A:B").Select 

Selection.EntireColumn.AutoFit 

Ort, wo es

.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