excel - 最初の列の値に応じて、各行を別のワークブックにコピーする

Question

別のプログラムからエクスポートされた既知の順序で顧客の詳細があるワークブックがあります。列 B に名、列 C に姓など。詳細が異なる約 20 列と、顧客が異なる複数の行があります。

これらの詳細を 2 つの異なるワークブックにエクスポートしたいと考えています。

3 つのワークブックがあるとします。

詳細が送信される連絡先のcoco
販売のためのリードリードと
メールアドレス帳のメール

これらのワークブックには既に行があるため、エクスポートされたものは最後の行に移動する必要があります。

これら 2 つのワークブックの列は、まったく異なる順序になっています。たとえば、セル B4 はリードでは C 列に、メールでは D 列に移動する必要があります。

ただし、すべての連絡先がワークブック、リード、および電子メールの両方に移動することは望ましくありません。coco のすべての行の前に、ユーザーがその行の詳細を見込み客、電子メール、またはその両方に移動するかどうかを選択できるドロップダウンリストがあります。

列を1つずつ移動するコードの作成を開始しました。そうすれば、はるかに簡単だったでしょう。しかし、行をエクスポートする場所をユーザーが選択できるようにする必要があることに気付きました。ロジックはもはや私にとってそれほど単純ではありません。

すべての行 (および行内のすべてのセル) を 1 つずつ処理する必要があります。最初に行を処理し、次にその中のセルを処理する 2 つのネストされたループが必要だと思います。

この下が私が始めたところです。使い道が全くわからない。その後もいくつかの実験を行ったので、少し面倒に見えるかもしれませんが、とにかく貼り付けてください。

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

前もって感謝します、 Joonas

score 0 · Accepted 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

手伝ってくれてありがとう！

score 0 · Accepted Answer

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

やるべきだ、頑張って

excel - 最初の列の値に応じて、各行を別のワークブックにコピーする

2 に答える 2

Related

Reference