我有一个工作簿，其中有从另一个程序导出的已知订单中的客户详细信息。 B列中的名字，C列中的姓氏，依此类推。大约有20列具有不同的细节，多行具有不同的客户。
我希望将这些细节导出到两个不同的工作簿中。
假设有3本工作簿：
这些工作簿中已有行，因此导出的内容应该转到最后一行。
这两个工作簿中的列完全不同。因此，例如，单元格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
提前致谢，Joonas
答案 0 :(得分：0)
Dim dest As Range
Set dee = Application.InputBox(prompt:="enter destination cell ref ex sheet1!a1", Type:=8)
应该这样做，祝你好运
答案 1 :(得分：0)
好的，这是我的决议。我可以更准确地解决问题和我的床单。正如我所说，这远非最佳，因为有一些不必要的重复。我首先尝试使用更多的子程序但由于某些声明问题而无效。可能有些变量只是声明了两次。
但无论如何它在这里。我删除了一些太识别的部分。
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
感谢您的帮助！