根据行数据复制特定单元格并粘贴到特定工作表上

Posted 2021-03-27

我是VBA的新手，我在根据其第一个单元格值复制特定行时遇到问题，并将其粘贴到另一个工作簿中，并将其粘贴到与此行相同的工作表中。

例：

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

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

我需要复制第2行并在第一个空行的另一个工作簿中的“Entregas”工作表上粘贴非空列（C，D，E，F，I，J，K和L）。

在第一行空行的“Auditoria / Controle Interno”表中使用第3行和第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("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" & 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

---

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

另一答案

我可以解决适应@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("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" & 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