根據行數據復制特定的單元格並粘貼在特定的工作表上

Question

我是VBA的新手，無法根據其第一個單元格值復制特定行，然后將其粘貼到另一個工作簿中，並將其粘貼到與該行相同的工作表中。

例：

另一個工作簿上的工作表是：

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

我需要復制第2行，並將非空列（C，D，E，F，I，J，K和L）粘貼到第一行的另一本工作簿的“ Entregas”表上。

對第3行的第一個空白行的“ Auditoria / Controle Interno”表上的C，D，E，F，I，J和K列執行相同的操作，依此類推...

我的代碼是這個，但是它復制並粘貼了整行，而我只需要粘貼非空單元格。

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

由於我不清楚您將如何確定該測試代碼為我擁有的每張工作表所屬的行，因此效果很好。 您不必執行所有這些復制和粘貼操作，只需了解有關循環的更多信息，它就更簡單了。 無論如何，代碼是：

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

我的評論建議示例：

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

Answer 3

我可以解決適應@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