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

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

3 个答案: