如果目标单元格不是空白，则如何复制同一行中的特定单元格

Question

如何才能使此工作成功？

命名为 “1” 的工作簿：
对于范围B2：R90，
如果B2是不是空白的，然后复制C2，E2，G2，L2 & M2，
自动打开的工作簿命名为 “2”，
如果B3不为空，则粘贴到B2,
，然后复制C3，E3，G3，L3,&M3，粘贴到工作簿“2”的B3，然后继续。
完成后，关闭并保存工作簿“2”，但保留工作簿“1”，打开。

我只知道用下面的方法来写代码，但是我相信这不能工作...> <

For Each cell In Sheets("01OCT") 
    If Not IsEmpty(Range("B5:R90").Value) Then 
     Copy 
     Else 
     Nothing 
    End If 
Next 

Answer 1

假设你的意思是增加细胞在其中粘贴值（B2，B3 ...）每一次不覆盖B2，假设你不需要任何东西，除了单元格内容，下面应该为你工作：

Sub copyCells() 
    Dim mainWb As Workbook, mainWs As Worksheet 
    Dim someWb As Workbook 

    Set mainWb = ThisWorkbook 
    Set mainWs = mainWb.Worksheets("01OCT") 

    Application.ScreenUpdating = False 

    Workbooks.Open fileName:="C:\path\2.xlsx", ReadOnly:=False 
    Set someWb = Workbooks("2.xlsx") 
    mainWs.Activate 

    For i = 2 To mainWs.Range("B5:R90").Rows.count 
     If Not IsEmpty(Range("B" & i).Value) Then 
      someWb.Worksheets(1).Range("B" & i).Value = mainWs.Range("C" & i).Value 
      someWb.Worksheets(1).Range("C" & i).Value = mainWs.Range("E" & i).Value 
      someWb.Worksheets(1).Range("D" & i).Value = mainWs.Range("G" & i).Value 
      someWb.Worksheets(1).Range("E" & i).Value = mainWs.Range("L" & i).Value 
      someWb.Worksheets(1).Range("F" & i).Value = mainWs.Range("M" & i).Value 
     End If 
    Next i 

    Workbooks("2.xlsx").Close SaveChanges:=True 

    Application.ScreenUpdating = True 
End Sub 

Answer 2

更改文件夹名称&工作簿名称&表名称适合

Sub GetDataTo2() 
    Dim wb As Workbook 
    Dim ws As Worksheet 
    Dim r As Long 

    Dim bk As Workbook 
    Dim sh As Worksheet 
    Dim rws As Long 

    Set wb = Workbooks("1.xlsm") 
    Set ws = wb.Sheets("Sheet1") 
    Application.ScreenUpdating = 0 

    With ws 
     r = .Cells(.Rows.Count, "B").End(xlUp).Row 
     .Columns("B:B").AutoFilter Field:=1, Criteria1:="<>" 

     Set bk = Workbooks.Open("C:\Users\Dave\Downloads\2.xlsx") 
     Set sh = bk.Sheets("Sheet1") 

     With sh 
      rws = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 
      ws.Range("C2:C" & r & ",E2:E" & r & ",G2:G" & r & ",L2:M" & r).Copy 
      .Range("A" & rws).PasteSpecial xlPasteValues 
     End With 

     bk.Save 
     bk.Close True 
     .AutoFilterMode = 0 
    End With 

End Sub