Vba 仅当列中的某些单元格为空时才复制和粘贴

我希望你能帮忙。我有下面的代码。基本上，它所做的是打开一个对话框，允许用户选择excel工作表，然后转到国家栏（11）过滤它，然后将该国家复制并粘贴到新工作簿中，在该国家后命名新工作簿，然后重复下一个国家的操作，然后保存并关闭每个工作簿

代码按原样完美地工作，但我现在想要它做的是，在标题下的a、B或C列中是否有一个单元格，或两个单元格或三个单元格为空。我希望它只为每个国家复制和粘贴这些行

所以在我下面的图片中，我想要代码做的是，去啊，我看到A5单元格是空白的，复制这一行，把它放到比利时工作簿中，继续，去啊，我看到A14单元格是空白的，复制这一行，放到保加利亚工作簿中，C17单元格是空白的，复制这一行，放到保加利亚工作簿中。Ah单元格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

子打开工作簿对话框（）
将my_文件名设置为变体
将我的工作簿设置为工作簿
MsgBox“选择您的CRO文件”使用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

如果先按国家进行筛选，并且不需要检查每行中的国家名称，则不需要循环，只需将其复制并粘贴为一组specialcells@Mak：谢谢你的帮助。我很想尝试一下你提供的代码，但是在我现有的代码中，我将把这个新代码放在哪里？@PhilipConnell:我已经更改了答案，如果您已经更改了，请替换您的副本代码，否则，就把它放在最后。@Mak:再次感谢您的帮助。非常感谢。我的Excel技能在需要的地方并不安静：-）我希望你能进一步帮助我。我试着插入你给我的密码。我删除了这一行并添加了您的代码
.SpecialCells（xlCellTypeVisible）。复制wb.Sheets（1）.Range（“A1”）
，但它没有覆盖空白。我做错什么了吗？