Copy specific cells according to row data and paste on specific sheet

Question

I am new to VBA and I am having trouble with copying a specific row according to its first cell value, and paste it in another workbook into a sheet named as the same of this row.

Example:

The sheets on the another workbook are:

Entregas, Demandas, Cliente, Regulatório, Auditoria/Controle Interno, COP

I need to copy row 2 and paste non-empty columns (C, D, E, F, I, J, K and L) on the "Entregas" sheet in another workbook on the first empty row.

Do the same with row 3 with the columns C, D, E, F, I, J and K on the "Auditoria/Controle Interno" sheet on the first empty row, and so on...

The code i have is this, but it copies and pastes the entire row while I need it to paste just the non-empty cells.

Sub Botão2_Clique()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim copyFrom As Range
    Dim lRow As Long '<~~ Not Integer. Might give you error in higher versions of excel
    Dim strSearch As String

    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Worksheets("Planilha1")

    strSearch = "Entregas"

    With ws1

        '~~> Remove any filters
        .AutoFilterMode = False

        '~~> I am assuming that the names are in Col A
        '~~> if not then change A below to whatever column letter
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        With .Range("A1:A" & lRow)
            .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
            Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With

    '~~> Destination File
    Set wb2 = Application.Workbooks.Open("\\BBAFSWCORP\dpt\DWS\SPLC\GerProc_Der_RF_RV\Renda Fixa\Equipe\Metas\Atividades_RF_2019.xlsm")
    Set ws2 = wb2.Worksheets(strSearch)

    With ws2
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lRow = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            lRow = 1
        End If

        copyFrom.Copy .Rows(lRow)
    End With

    wb2.Save
    wb2.Close

Answer 1

Since I'm not clear how will you determine which row belongs to each sheet I have for you this tested code, it works fine. You don't have to do all this copy and pastes, just learn more about loops, it's more simple. Anyway the code is:

Sub test()
  Dim wb1 As Workbook
  Dim wb2 As Workbook

  Dim wsh1 As Worksheet
  Dim wsh2 As Worksheet

 Dim lRow As Long

 Dim i As Long

 i = 1

 Set wb1 = ThisWorkbook
 Set wsh1 = wb1.Worksheets("Planilha1")


 Set wb2 = Application.Workbooks.Open("\\BBAFSWCORP\dpt\DWS\SPLC\GerProc_Der_RF_RV\Renda Fixa\Equipe\Metas\Atividades_RF_2019.xlsm")
 Set wsh2 = wb2.Worksheets("Entregas")


 lRow = wsh2.Range("A" & wsh2.Rows.Count).End(xlUp).Row + 1

 Dim cell As Range

 For Each cell In wsh1.Range("A2:L2").Cells

    If Not cell.Value = "" Then

    wsh2.Cells(lRow, i) = cell.Value

    i = i + 1
    End If
 Next cell

End Sub

Answer 2

Example of my suggestion from comments:

dim f as range, c as long, i as long, arr as variant, swb as workbook, dwb as workbook
set swb = ActiveWorkbook 'source workbook
set dwb = Workbooks("Destination") 'dest. workbook
arr = array("Terma","Beneficio") 'examples from your prefered column names
for i = lbound(arr) to ubound(arr) 'should start on 0
    with swb.sheets("Entregas")
        set f = .Find(What:=arr(i), LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        c = f.column
        dwb.sheets("DESTSheet").Columns(i+1).value = .Columns(c)
    end with
next i

---

Edit1:

Will add in a way to help with the sorting to better utilize something similar to the above example (where you can sort for a key in column 1 to deal with chunks of data at a time):

dim clt as new collection, i as long, lr as long
with sheets("Entregas")
    lr = .cells(.rows.count,1).end(xlup).row
    for i = 1 to lr
        clt.add .cells(i,1).value, .cells(i,1).value 'collections capture UNIQUE values, so this should sort itself, unless you want to use an array of known sheets... either or
    next i
    for i = 1 to clt.count
        'use the item OR key from clt as the sheet name
        'dest.columns(i).value = source.columns(c).value, and match columns like the initial example
    next i
end with

Answer 3

I could solve the problem adapting @Erjons Sub

Need to polish the code here and there, but this works fine. if someone's have any tips on how to improve it or if i put some redundant argument, please let me know... Always have one or two things that can improve, in my case, i have a lot to improve.

Here's the code:

Sub Enviar_Dados()
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim wsh1 As Worksheet
    Dim wsh2 As Worksheet
    Dim lRow As Long, lRow2 As Long
    Dim i As Long
    Dim r As Long
    Dim rCell As Range
    Dim rRng As Range
    Dim a As Range, b As Range
    Dim c As String

    Set wb1 = ThisWorkbook
    Set wsh1 = wb1.Worksheets("Planilha1")
    lRow2 = wsh1.Range("A" & wsh1.Rows.Count).End(xlUp).row
    Set a = wsh1.Range("A2:A" & lRow2)
    Set wb2 = Application.Workbooks.Open("\\BBAFSWCORP\dpt\DWS\SPLC\GerProc_Der_RF_RV\Renda Fixa\Equipe\Metas\Atividades_RF_2019.xlsm")
    r = 2

    For Each b In a.Rows
        If b <> "Demandas" Then
            c = b.Value
            i = 1
            Set wsh2 = wb2.Worksheets(c)
            lRow = wsh2.Range("A" & wsh2.Rows.Count).End(xlUp).row + 1
            Dim cell As Range
                For Each cell In wsh1.Range("B" & r & ":L" & r).Cells
                    If Not cell.Value = "" Then
                        wsh2.Cells(lRow, i) = cell.Value
                        i = i + 1
                    End If
                Next cell
        ElseIf b = "Demandas" Then
            c = wsh1.Range("B" & r)
            i = 1
            Set wsh2 = wb2.Worksheets(c)
            lRow = wsh2.Range("A" & wsh2.Rows.Count).End(xlUp).row + 1
                For Each cell In wsh1.Range("C" & r & ":L" & r).Cells
                    If Not cell.Value = "" Then
                        wsh2.Cells(lRow, i) = cell.Value
                        i = i + 1
                    End If
                Next cell
        End If

    r = r + 1

    Next b

    wb2.Save
    wb2.Close
    wsh1.Range("A2:L" & lRow2).ClearContents

End Sub