仅当列中的某些单元格为空时，才会复制并粘贴

Question

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

该代码完全按照原样工作，但我现在要做的是在单元格中，或者在标题下的列A，B或C中有两个单元格或三个单元格为空白。我希望它只为每个国家复制和粘贴这些行。

因此，在我的图片下面我想要的代码是去啊我看到单元格A5是空白复制此行并将其放到比利时工作簿，继续前进去啊我看到单元格A14是空白副本这一行放在保加利亚工作簿中，Cell C17是空白的复制这一行并放入保加利亚工作簿。 Ah Cell A26，B26和C26空白复制此行并将其放入克罗地亚工作簿中。

一如既往的任何帮助，非常感谢。

这里是我的照片

这里是我的代码

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 
          Sheets(1).Range("A1:Y1").WrapText = False 'Takes the wrap text off 
          ActiveWindow.Zoom = 55 
         Sheets(1).UsedRange.Columns.AutoFit 'Autofits the column 
        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

它是通过使用xlCellTypeBlanks复制整行方便。 清除所有过滤器和 更换您复制代码如果你有，否则，把它放在最后

dim country as string 
row = activesheet.usedrange.rows.count 
activesheet.range("A1:C" & row).SpecialCells(xlCellTypeBlanks).entirerow.select 
for each r in selection.rows 
    country=activesheet.cells(r.row,11) 
    r.copy 
    application.workbook(country).sheet(1).rows(1).insert 'assume that your country workbook is already opened 
next