Скопируйте определенные ячейки в соответствии с данными строки и вставьте на определенный лист

Question

Я новичок в VBA, и у меня возникают проблемы с копированием определенной строки в соответствии с ее первым значением ячейки и вставкой ее в другую книгу в лист с именем, совпадающим с именем этой строки.

Пример:

Листы в другой книге:

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

Мне нужно скопировать строку 2 и вставить непустые столбцы(C, D, E, F, I, J, K и L) на листе «Entregas» в другой книге в первой пустой строке.

То же самое сделайте со строкой 3 со столбцами C, D, E, F, I, J и K на листе «Auditoria / Controle Interno» в первой пустой строке и т. Д. *

У меня есть такой код, но он копирует и вставляетвсю строку, пока мне нужно вставить только непустые ячейки.

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

Пример моего предложения из комментариев:

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:

Добавит способ, помогающий сортировке, чтобы лучше использовать что-то похожее на приведенный выше пример (где вы можете отсортировать ключ в столбце 1 для обработки порций данных одновременно):

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 2

Я мог бы решить проблему с адаптацией @Erjons Sub

Нужно полировать код здесь и там, но это прекрасно работает.если у кого-то есть какие-либо советы о том, как его улучшить, или если я приведу какой-то лишний аргумент, пожалуйста, дайте мне знать ... Всегда есть одна или две вещи, которые можно улучшить, в моем случае, мне многое нужно улучшить.

Вот код:

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

Answer 3

Поскольку мне неясно, как вы будете определять, какая строка принадлежит каждому листу, у меня есть для вас этот проверенный код, он работает нормально.Вам не нужно делать все эти копии и вставки, просто узнайте больше о циклах, это проще.В любом случае код:

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