title: VBA: Select cells in column, copy multiple cells from the selected cells´ rows and copy into another workbook
body: <p>I tried to create a macro (and searched Google for what feels like forever), but did still not resolve my issue, where I can select one or multiple cells in e.g. column A and run the macro. Then the macro should copy paste data from several cells within the selected cells´ rows to specific cells in another workbook. I hope it makes sense so far.</p>
  
  <p>Anyhow, here is an example:<br>
  If I select <code>A1</code>, <code>A2</code>, <code>A4</code> and run the macro, the follow cells should be copied to a new workbook:</p>
  
  <pre><code>A1, A2, A4 --&gt; B1, B2, B4
  F1, F2, F4 --&gt; D1, D2, D4
  E1, E2, E4 --&gt; F1, F2, F4
  etc. so I can edit/change it depending on my need.
  </code></pre>
  
  <p>If it is possible, I would actually like the pasted data to start in row 13.
  I would appreciate if the code could be commented, so I can learn more about it :)</p>
  
  <p><strong>SOLVED IT</strong><br>
  <strong>* UPDATE *</strong><br></p>
  
  <pre><code>Sub CopyData()
  Dim wkbCurrent, wkbNew As Workbook
  Set wkbCurrent = ActiveWorkbook
  Dim valg, c, LastCell As Range
  Set valg = Selection
  Dim wkbPath, wkbFileName, lastRow As String
  Dim LastRowInput As Long
  Dim lrow, rwCount As Long
  
  Application.ScreenUpdating = False
  
  On Error GoTo errHandler
  
  wkbPath = ActiveWorkbook.Path &amp; "\"
  wkbFileName = Dir(wkbPath &amp; "CIF LISTEN.xlsm")
  
  Set wkbNew = Workbooks.Open(wkbPath &amp; "CIF LISTEN.xlsm")
  
  LastRowInput = Cells(Rows.count, "A").End(xlDown).Row
  
  ' If nothing is selected in column A
  ' GoTo Error Handling
  If valg.Cells(1, 1) = 0 Then
      GoTo errHandler
  End If
  
  For Each c In valg.Cells
      lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.count - 1, 0).End(xlUp).Row + 1
  
      wkbCurrent.ActiveSheet.Range("A" &amp; c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" &amp; lrow)
      wkbCurrent.ActiveSheet.Range("E" &amp; c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("A" &amp; lrow)
      wkbCurrent.ActiveSheet.Range("F" &amp; c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("F" &amp; lrow)
  Next
  
  'Range("A10").Value = "COMMENTS: " &amp; Selection.Rows.count &amp; " Suppliers Added"
  
  ' wkbNew.Close False
  ' wkbfilename = Dir
  
  ' Find the number of rows that is copied over
  wkbCurrent.ActiveSheet.Activate
  areaCount = Selection.Areas.count
  If areaCount &lt;= 1 Then
      MsgBox "The selection contains " &amp; Selection.Rows.count &amp; " suppliers."
      ' Write it in A10 in CIF LISTEN
      wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " &amp; Selection.Rows.count &amp; " Suppliers Added"
  Else
      I = 1
      For Each a In Selection.Areas
          'MsgBox "Area " &amp; I &amp; " of the selection contains " &amp; _
          a.Rows.count &amp; " rows."
          I = I + 1
          rwCount = rwCount + a.Rows.count
      Next a
      MsgBox "The selection contains " &amp; rwCount &amp; " suppliers."
      ' Write it in A10 in CIF LISTEN
      wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " &amp; rwCount &amp; " Suppliers Added"
  End If
  
  Application.ScreenUpdating = True
  
  ' Error Handling
  exitHandler:
  wkbNew.Close SaveChanges:=False
  Exit Sub
  errHandler:
  MsgBox "Please select cell(s) in column A", vbCritical, "Error"
  Resume exitHandler
  End Sub
  </code></pre>