excel - 根据第一列的值将每一行复制到另一个工作簿

Question

我有一个工作簿，其中有从另一个程序导出的已知订单中的客户详细信息。B列中的名字，C列中的姓氏，依此类推。大约有 20 列具有不同的详细信息，并且具有不同客户的多行。

我希望将这些详细信息导出到两个不同的工作簿。

假设有 3 个工作簿：

• coco用于发送详细信息的联系人
• 销售线索和
• 用于电子邮件通讯录的电子邮件

这些工作簿中已经有行，因此导出的内容应该放在最后一行。

这两个工作簿中的列的顺序完全不同。因此，例如单元格 B4 应转到潜在客户的 C 列和电子邮件中的 D 列。

但是，我不希望每个联系人同时访问工作簿、潜在客户和电子邮件。在 coco 中的每一行之前都有一个下拉列表，用户可以在其中选择她/他是否希望将该行的详细信息移动到潜在客户、电子邮件或两者兼而有之。

我开始编写代码来一一移动列。这样一来，事情就会简单得多。但是我意识到，用户应该可以选择要导出行的位置，逻辑对我来说不再那么简单了。

每一行（以及一行中的每个单元格）都必须一个一个地处理。我想应该有两个嵌套循环首先处理行，然后处理其中的单元格。

下面是我开始的地方。我根本不知道它是否可用。之后我也做了一些实验，所以看起来有点乱，但无论如何都要粘贴它。

Public lastrowcoco, lastrowleads, lastrowemail As Long
Public shtcoco As Worksheet
Public shtleads As Worksheet
Public wkbname As String
Public wkbcoco As Workbook
Public wkbleads As Workbook
Public rngcoco As Range
Public rowcoco As Range
Public lc, ll, le, nc, nl, ne As Long

Public Sub CopyCells()


    wkbname = ActiveWorkbook.Name
    Set wkbcoco = Workbooks(wkbname)
    With wkbcoco
        activesheet.Name = "Transfer"
    End With

    With wkbcoco
        lastrowcoco = Range("D" & Rows.Count).End(xlUp).row
    End With



    Call Copy("B", "D")

lastrowcoco = Empty
lastrowleads = Empty

End Sub
Sub Copy(c As String, Optional le As String, Optional e As String)

    Set shtcoco = wkbcoco.Sheets("Transfer")

    shtcoco.Range(c & "2:" & c & lastrowcoco).Copy

    Set wkbleads = Workbooks.Open("U:\leads.xls")
    Set shtleads = wkbleads.Sheets("Leads")

    With shtleads
        lastrowleads = .cells(Rows.Count, "D").End(xlUp).row
    End With

    shtleads.Range(le & 1 + lastrowleads).PasteSpecial


    'wkbleads.Close

End Sub

在此先感谢，乔纳斯

Answer 1

Dim dest As Range
Set dee = Application.InputBox(prompt:="enter destination cell ref ex sheet1!a1", Type:=8)

应该做，祝你好运

Answer 2

好的，这是我的决议。我本来可以更准确地了解这个问题和我的床单。正如我所说，这远非最佳，因为有一些不必要的重复。我首先尝试使用更多子程序，但由于一些声明问题，它没有工作。可能有些变量只声明了两次。

但无论如何，它就在这里。我删除了一些过于识别的部分。

    Sub Copycat()
    Dim i As Long
    Dim rCount As Long
    Dim r As Range
    Dim today As Date
    Dim cell As Range
    Dim Msg As Variant

    If Range("A1") = "Transfer" Then
        Msg = MsgBox("It looks like the script is already executed." & Chr(10) & "Do you really want to execute it again?" & Chr(10) & Chr(10) & "It will add the new columns as double.", vbYesNo, "")
            If Msg = vbNo Then
                Exit Sub
            End If
    End If

    If Not Range("B1") = "FirstName" Then
        Msg = MsgBox("It looks like this sheet is not the right file" & Chr(10) & "Do you really want to execute the script?" & Chr(10) & Chr(10) & "Unsaved changes will be lost.", vbYesNo, "")
            If Msg = vbNo Then
                Exit Sub
            End If
    End If

    'Add columns
    Range("I:T").Insert Shift:=xlToLeft
    'Add/change subjects
    Range("A1") = "Transfer"
    Range("C1") = "Seller"
    Range("E1") = ""
    Range("G1") = ""
    Range("T1") = ""
    'Add validation values
    Range("AO2") = "Product1"
    Range("AO3") = "Product2"


    'Removed

    Range("AQ2") = "Both"
    Range("AQ3") = "Email"
    Range("AQ4") = "Leads"

    'Removed


    Range("AU2") = "Prospect"
    Range("AU3") = "Competitor"
    Range("AU4") = "Partner"
    Range("AU5") = "Yes"



    With ActiveSheet
    rCount = .Cells(.Rows.Count, "D").End(xlUp).row
    'rCount = ActiveSheet.Range(Rows.Count).End(xlUp).Row
    End With

    'r = Range("J2:J" & rCount)

    For Each cell In Range("J2:J" & rCount)
        cell = Date
    Next
    For Each cell In Range("K2:K" & rCount)
        cell = "Email"
    Next
    For Each cell In Range("O2:O" & rCount)
        cell = "Prospect"
    Next
    For Each cell In Range("N2:N" & rCount)
        cell = "Glass"
    Next
    For Each cell In Range("C2:C" & rCount)
        cell = "RJ"
    Next


     With ActiveSheet.Range("Q2:Q" & rCount).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=$AO$2:$AO$7"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With

     With ActiveSheet.Range("C2:C" & rCount).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=$AV$2:$AV$4"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With

     With ActiveSheet.Range("O2:O" & rCount).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=$AU$2:$AU$5"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With

     With ActiveSheet.Range("M2:M" & rCount).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=$AP$2:$AP$12"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With
     With ActiveSheet.Range("A2:A" & rCount).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=$AQ$2:$AQ$4"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With
         With ActiveSheet.Range("K2:K" & rCount).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=$AR$2:$AR$7"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With
     With ActiveSheet.Range("N2:N" & rCount).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=$AS$2:$AS$5"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With
         With ActiveSheet.Range("P2:P" & rCount).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=$AT$2:$AT$7"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With
             With ActiveSheet.Range("N2:N" & rCount).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=$AS$2:$AS$5"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With
            With ActiveSheet.Range("A2:A" & rCount).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=$AQ$2:$AQ$4"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With

        ActiveSheet.Buttons.Add(500, 300, 105, 25).Select
        Selection.OnAction = "PERSONAL.XLSB!Copycat2"
        With Selection.Font
            .Name = "Submit"
            .Size = 15
        End With
            Selection.Characters.Text = "Submit"

        Range("F25") = "When all the details are filled in, press the button:"
        Cells(1, 1).Select
    End Sub



    Sub Copycat2()

        Dim lastrowcoco, lastrowleads, lastrowemail As Long
        Dim shtcoco, shtleads, shtemail As Worksheet
        Dim wkbname, shtname As String
        Dim wkbcoco, wkbleads, wkbemail As Workbook
    Application.ScreenUpdating = False
    If Not ActiveSheet.Cells(1, 2).Value = "FirstName" Then
        MsgBox ("It looks like the sheet where you are running the script is not " & Chr(10) & "from the right one. Check that you have the right sheet active.")
        Exit Sub
    End If

    Dim currentRow As Integer
    Dim b, v, i, rCount, rCounte As Integer
    rCount = 0
    rCounte = 0

        wkbname = ActiveWorkbook.Name
        Set wkbcoco = Workbooks(wkbname)
        shtname = ActiveSheet.Name
        Set shtcoco = wkbcoco.Worksheets(shtname)

        Set wkbleads = Workbooks.Open("saleleads file.xls")
        Set shtleads = wkbleads.Sheets("Leads")

        Set wkbemail = Workbooks.Open("G:\email list file.xls")
        Set shtemail = wkbemail.Sheets("Sheet1")

        With shtleads
            lastrowleads = .Cells(Rows.Count, "D").End(xlUp).row + 1
        End With
        With shtcoco
            lastrowcoco = .Cells(Rows.Count, "D").End(xlUp).row
        End With
        With shtemail
            lastrowemail = .Cells(Rows.Count, "D").End(xlUp).row + 1
        End With
        For i = 2 To lastrowcoco
            If shtcoco.Cells(i, 1).Value = "Leads" Then
                t = 1
            ElseIf shtcoco.Cells(i, 1).Value = "Email" Then
                t = 2
            ElseIf shtcoco.Cells(i, 1).Value = "Both" Then
                t = 3
            End If

                Select Case t
                    Case Is = 1
                        For b = 1 To 33 Step 1
                            shtcoco.Cells(i, b).Copy
                                    Select Case b
                                        Case Is = 2
                                            shtleads.Cells(lastrowleads + rCount, 22).PasteSpecial xlPasteValues
                                        Case Is = 4
                                            shtleads.Cells(lastrowleads + rCount, 23).PasteSpecial xlPasteValues
                                        Case Is = 6
                                            shtleads.Cells(lastrowleads + rCount, 2).PasteSpecial xlPasteValues
                                        Case Is = 8
                                            shtleads.Cells(lastrowleads + rCount, 24).PasteSpecial xlPasteValues
                                        Case Is = 9
                                            shtleads.Cells(lastrowleads + rCount, 25).PasteSpecial xlPasteValues
                                        Case Is = 10
                                            shtleads.Cells(lastrowleads + rCount, 4).PasteSpecial xlPasteValues
                                        Case Is = 11
                                            shtleads.Cells(lastrowleads + rCount, 5).PasteSpecial xlPasteValues
                                        Case Is = 12
                                            shtleads.Cells(lastrowleads + rCount, 7).PasteSpecial xlPasteValues
                                        Case Is = 13
                                            shtleads.Cells(lastrowleads + rCount, 8).PasteSpecial xlPasteValues
                                        Case Is = 14
                                            shtleads.Cells(lastrowleads + rCount, 9).PasteSpecial xlPasteValues
                                        Case Is = 15
                                            shtleads.Cells(lastrowleads + rCount, 10).PasteSpecial xlPasteValues
                                        Case Is = 16
                                            shtleads.Cells(lastrowleads + rCount, 11).PasteSpecial xlPasteValues
                                        Case Is = 17

                                            End If
                                        Case Is = 18
                                            shtleads.Cells(lastrowleads + rCount, 29).PasteSpecial xlPasteValues
                                        Case Is = 19
                                            shtleads.Cells(lastrowleads + rCount, 30).PasteSpecial xlPasteValues
                                        Case Is = 22
                                            shtleads.Cells(lastrowleads + rCount, 31).PasteSpecial xlPasteValues
                                        Case Is = 23
                                            shtleads.Cells(lastrowleads + rCount, 32).PasteSpecial xlPasteValues
                                        Case Is = 24
                                        Case Is = 25
                                            shtleads.Cells(lastrowleads + rCount, 33).PasteSpecial xlPasteValues
                                            shtleads.Cells(lastrowleads + rCount, 3).PasteSpecial xlPasteValues
                                        Case Is = 29
                                            shtleads.Cells(lastrowleads + rCount, 27).PasteSpecial xlPasteValues
                                        Case Is = 28
                                            shtleads.Cells(lastrowleads + rCount, 26).PasteSpecial xlPasteValues
                                        Case Is = 30
                                            shtleads.Cells(lastrowleads + rCount, 20).PasteSpecial xlPasteValues
                                        Case Is = 31
                                            shtleads.Cells(lastrowleads + rCount, 28).PasteSpecial xlPasteValues
                                        Case Is = 32
                                            If shtcoco.Cells(i, b).Value = "M" Then
                                                shtleads.Cells(lastrowleads + rCount, 21).Value = "Mr."
                                            ElseIf shtemail.Cells(i, b).Value = "F" Then
                                                shtleads.Cells(lastrowleads + rCount, 21).Value = "Ms."
                                            Else: shtleads.Cells(lastrowleads + rCount, 21).PasteSpecial xlPasteValues
                                            End If
                                    End Select
                        Next b
                    Case Is = 2
                        For b = 1 To 33 Step 1
                            shtcoco.Cells(i, b).Copy
                                    Select Case b
                                        Case Is = 2
                                            shtemail.Cells(lastrowemail + rCounte, 4).PasteSpecial xlPasteValues
                                        Case Is = 3
                                        shtemail.Cells(lastrowemail + rCounte, 13).PasteSpecial xlPasteValues
                                        Case Is = 4
                                            shtemail.Cells(lastrowemail + rCounte, 5).PasteSpecial xlPasteValues
                                        Case Is = 6
                                            shtemail.Cells(lastrowemail + rCounte, 6).PasteSpecial xlPasteValues
                                        Case Is = 9
                                            shtemail.Cells(lastrowemail + rCounte, 16).PasteSpecial xlPasteValues
                                        Case Is = 10
                                            shtemail.Cells(lastrowemail + rCounte, 14).PasteSpecial xlPasteValues
                                        Case Is = 11
                                            shtemail.Cells(lastrowemail + rCounte, 15).PasteSpecial xlPasteValues
                                        Case Is = 13
                                            shtemail.Cells(lastrowemail + rCounte, 9).PasteSpecial xlPasteValues
                                        Case Is = 15
                                            shtemail.Cells(lastrowemail + rCounte, 8).PasteSpecial xlPasteValues
                                        Case Is = 17
                                            shtemail.Cells(lastrowemail + rCounte, 10).PasteSpecial xlPasteValues
                                        Case Is = 30
                                            shtemail.Cells(lastrowemail + rCounte, 2).PasteSpecial xlPasteValues
                                        Case Is = 25
                                            shtemail.Cells(lastrowemail + rCounte, 7).PasteSpecial xlPasteValues
                                        Case Is = 32
                                            If shtcoco.Cells(i, b).Value = "M" Then
                                                shtemail.Cells(lastrowemail + rCounte, 3).Value = "Mr."
                                            ElseIf shtemail.Cells(i, b).Value = "F" Then
                                                shtemail.Cells(lastrowemail + rCounte, 3).Value = "Ms."
                                            Else: shtemail.Cells(lastrowemail + rCounte, 3).PasteSpecial xlPasteValues
                                            End If
                                    End Select
                        Next b
                    Case Is = 3
                        For b = 1 To 33 Step 1
                            shtcoco.Cells(i, b).Copy
                                    Select Case b
                                        Case Is = 2
                                            shtleads.Cells(lastrowleads + rCount, 22).PasteSpecial xlPasteValues
                                            shtemail.Cells(lastrowemail + rCounte, 4).PasteSpecial xlPasteValues
                                        Case Is = 3
                                            shtemail.Cells(lastrowemail + rCounte, 13).PasteSpecial xlPasteValues
                                        Case Is = 4
                                            shtleads.Cells(lastrowleads + rCount, 23).PasteSpecial xlPasteValues
                                            shtemail.Cells(lastrowemail + rCounte, 5).PasteSpecial xlPasteValues
                                        Case Is = 6
                                            shtleads.Cells(lastrowleads + rCount, 2).PasteSpecial xlPasteValues
                                            shtemail.Cells(lastrowemail + rCounte, 6).PasteSpecial xlPasteValues
                                        Case Is = 8
                                            shtleads.Cells(lastrowleads + rCount, 24).PasteSpecial xlPasteValues
                                        Case Is = 9
                                            shtleads.Cells(lastrowleads + rCount, 25).PasteSpecial xlPasteValues
                                            shtemail.Cells(lastrowemail + rCounte, 16).PasteSpecial xlPasteValues
                                        Case Is = 10
                                            shtleads.Cells(lastrowleads + rCount, 4).PasteSpecial xlPasteValues
                                            shtemail.Cells(lastrowemail + rCounte, 14).PasteSpecial xlPasteValues
                                        Case Is = 11
                                            shtleads.Cells(lastrowleads + rCount, 5).PasteSpecial xlPasteValues
                                            shtemail.Cells(lastrowemail + rCounte, 15).PasteSpecial xlPasteValues
                                        Case Is = 12
                                            shtleads.Cells(lastrowleads + rCount, 7).PasteSpecial xlPasteValues
                                        Case Is = 13
                                            shtleads.Cells(lastrowleads + rCount, 8).PasteSpecial xlPasteValues
                                            shtemail.Cells(lastrowemail + rCounte, 9).PasteSpecial xlPasteValues
                                        Case Is = 14
                                            shtleads.Cells(lastrowleads + rCount, 9).PasteSpecial xlPasteValues
                                        Case Is = 15
                                            shtleads.Cells(lastrowleads + rCount, 10).PasteSpecial xlPasteValues
                                            shtemail.Cells(lastrowemail + rCounte, 8).PasteSpecial xlPasteValues
                                        Case Is = 16
                                            shtleads.Cells(lastrowleads + rCount, 11).PasteSpecial xlPasteValues
                                        Case Is = 17
                                            shtemail.Cells(lastrowemail + rCounte, 10).PasteSpecial xlPasteValues                                                
                                        Case Is = 18
                                            shtleads.Cells(lastrowleads + rCount, 29).PasteSpecial xlPasteValues
                                        Case Is = 19
                                            shtleads.Cells(lastrowleads + rCount, 30).PasteSpecial xlPasteValues
                                        Case Is = 22
                                            shtleads.Cells(lastrowleads + rCount, 31).PasteSpecial xlPasteValues
                                        Case Is = 23
                                            shtleads.Cells(lastrowleads + rCount, 32).PasteSpecial xlPasteValues
                                        Case Is = 24
                                        Case Is = 25
                                            shtleads.Cells(lastrowleads + rCount, 33).PasteSpecial xlPasteValues
                                            shtleads.Cells(lastrowleads + rCount, 3).PasteSpecial xlPasteValues
                                            shtemail.Cells(lastrowemail + rCounte, 7).PasteSpecial xlPasteValues
                                        Case Is = 29
                                            shtleads.Cells(lastrowleads + rCount, 27).PasteSpecial xlPasteValues
                                        Case Is = 28
                                            shtleads.Cells(lastrowleads + rCount, 26).PasteSpecial xlPasteValues
                                        Case Is = 30
                                            shtleads.Cells(lastrowleads + rCount, 20).PasteSpecial xlPasteValues
                                            shtemail.Cells(lastrowemail + rCounte, 2).PasteSpecial xlPasteValues
                                        Case Is = 31
                                            shtleads.Cells(lastrowleads + rCount, 28).PasteSpecial xlPasteValues
                                        Case Is = 32
                                            If shtcoco.Cells(i, b).Value = "M" Then
                                                shtemail.Cells(lastrowemail + rCounte, 3).Value = "Mr."
                                                shtleads.Cells(lastrowleads + rCount, 21).Value = "Mr."
                                            ElseIf shtemail.Cells(i, b).Value = "F" Then
                                                shtemail.Cells(lastrowemail + rCounte, 3).Value = "Ms."
                                                shtleads.Cells(lastrowleads + rCount, 21).Value = "Ms."
                                            Else: shtleads.Cells(lastrowleads + rCount, 21).PasteSpecial xlPasteValues
                                                    shtemail.Cells(lastrowemail + rCounte, 3).PasteSpecial xlPasteValues
                                            End If
                                    End Select
                        Next b
                End Select

        If shtcoco.Cells(i, 1).Value = "Leads" Then
            rCount = rCount + 1
        ElseIf shtcoco.Cells(i, 1).Value = "Email" Then
            rCounte = rCounte + 1
        ElseIf shtcoco.Cells(i, 1).Value = "Both" Then
            rCount = rCount + 1
            rCounte = rCounte + 1
        End If
        Next i

    wkbemail.Close SaveChanges:=True
    wkbleads.Close SaveChanges:=True
    Application.ScreenUpdating = True

    MsgBox rCount & " rows(s) added to Leads and " & rCounte & " to Email list.", 0, "Transfer complete!"

    End Sub

感谢帮助！