Блог

Я новичок в 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 / Controlle 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" amp; .Rows.Count).End(xlUp).Row

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

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

    '~~> Destination File
    Set wb2 = Application.Workbooks.Open("\BBAFSWCORPdptDWSSPLCGerProc_Der_RF_RVRenda FixaEquipeMetasAtividades_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
  

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

 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("\BBAFSWCORPdptDWSSPLCGerProc_Der_RF_RVRenda FixaEquipeMetasAtividades_RF_2019.xlsm")
 Set wsh2 = wb2.Worksheets("Entregas")


 lRow = wsh2.Range("A" amp; 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
  

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

 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
  

Правка1:

Добавит способ, помогающий с сортировкой, чтобы лучше использовать что-то похожее на приведенный выше пример (где вы можете сортировать по ключу в столбце 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
  

Я мог бы решить проблему, адаптировав @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" amp; wsh1.Rows.Count).End(xlUp).row
    Set a = wsh1.Range("A2:A" amp; lRow2)
    Set wb2 = Application.Workbooks.Open("\BBAFSWCORPdptDWSSPLCGerProc_Der_RF_RVRenda FixaEquipeMetasAtividades_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" amp; wsh2.Rows.Count).End(xlUp).row   1
            Dim cell As Range
                For Each cell In wsh1.Range("B" amp; r amp; ":L" amp; 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" amp; r)
            i = 1
            Set wsh2 = wb2.Worksheets(c)
            lRow = wsh2.Range("A" amp; wsh2.Rows.Count).End(xlUp).row   1
                For Each cell In wsh1.Range("C" amp; r amp; ":L" amp; 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" amp; lRow2).ClearContents

End Sub