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

你可以制作一个额外的＆＃34;模板＆＃34;原始工作簿中的工作表，将格式化为源工作表。然后，将筛选的数据复制到模板工作表中，并将模板工作表复制为新工作簿。唯一的问题是，如果您更改源表的格式，则必须在模板表中执行相同的操作。

Answer 2

通常，当我需要小型MACRO做某事我犹豫如何实现时，我使用Excel的MACRO RECORDING功能。在你的情况下，我会开始录制，转到源表，选择并复制范围，转到目标表，单击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

VBA将粘贴格式从原始工作簿转换为新工作簿

3 个答案: