如果目標單元格不是空白，則如何複製同一行中的特定單元格

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