我有:
1)一个名为“Data”的工作表,用于我的产品数据库;
2)基于数据库中所选产品的产品报价,名为“报价ENG”的工作表;
3)一个名为“Manager”的工作表,带有下拉列表以选择条件。
然后,我有两段独立运行的代码。
一个名为Sub Quote的用于在满足条件时将我的数据库中的部分行复制粘贴到报价单,
一个名为Sub Worksheet_Change(信用:TrumpExcel)用于在下拉列表中启用多个选择。
如果下拉列表启用多个条件,我对如何更改Sub Quote模块的代码以使复制粘贴操作成为可能非常无能为力。欢迎任何指导:)
Sub Quote()
Dim Source As Worksheet
Dim Target As Worksheet
Dim Company As String
Dim InfoA As String
Dim Finalrow As Integer
Dim I As Integer
Set Source = Worksheets("Data")
Set Target = Worksheets("Quotation ENG")
Company = Worksheets("Manager").Range("E5").Value 'Where one dropdown list is located.
InfoA = Worksheets("Manager").Range("E7").Value 'Where one dropdown list is located.
Source.Select
Finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For I = 2 To Finalrow
If Cells(I, 1) = Company And Cells(I, 2) = InfoA Then
Source.Range(Cells(I, 16), Cells(I, 23)).Copy Target.Range("A200").End(xlUp).Offset(1, 0).Resize(1, 8)
End If
Next I
Target.Select
Range("A1").Select
End Sub
=============================================================
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Address = "$E$5" Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & ", " & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
我重构了代码的某些部分并将公司变量转换为数组,因此它可以存储多个值。请阅读代码中的注释。
建议,尝试使用Excel structured tables存储您的数据。将来与他们合作会更容易。
替换您当前的Quote Sub为此:
Sub Quote()
Dim Source As Worksheet
Dim Target As Worksheet
Dim Company() As String ' Converted the company variable to an array
Dim InfoA As String
Dim Finalrow As Integer
Dim counter As Integer
Dim I As Integer
Set Source = Worksheets("Data")
Set Target = Worksheets("Quotation ENG")
Company = Split(Worksheets("Manager").Range("E5").Value, ",") 'Where one dropdown list is located.
InfoA = Worksheets("Manager").Range("E7").Value 'Where one dropdown list is located.
' Added the source sheet and removed the select as it slows down your code
Finalrow = Source.Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each company contained in the array
For counter = 0 To UBound(Company)
' Loop through each data row
For I = 2 To Finalrow
' Added Company(counter) so you can access each array element and wrapped it with trim to delete extra spaces
If Source.Cells(I, 1) = Trim(Company(counter)) And Source.Cells(I, 2) = InfoA Then
Source.Range(Source.Cells(I, 16), Source.Cells(I, 23)).Copy Target.Range("A200").End(xlUp).Offset(1, 0).Resize(1, 8)
End If
Next I
Next counter
' Activate worksheet
Target.Activate
' Refer to the object full path
Target.Range("A1").Select
End Sub
如果有效,请告诉我。