无法为列表框中的多个项目执行宏

Question

我是新手。我刚刚写了一个代码，通过查看这些单元格的左侧相邻列中数字的前3个数字来复制一系列单元格。例如：如果A1和A5的前三个数字是100，则复制B1：D1和B5：D5到新工作簿。在开始时，我使用inputbox输入数字（100）来查找我想要复制的范围。现在我想使用多个输入。就像我想用一个代码复制100右侧的单元格到一个新的工作簿和120单元格到另一个新的工作簿...我使用listbox编写了一个代码。然而，问题是每当我选择多个项目，如100 110 120，它都不起作用。它将包含100的单元格的右侧相邻单元复制到新的工作簿，而不是将100的右侧单元格复制到另一个新工作簿。我被卡住了，等待一个人来照亮我。对不起，我的英文不是母语。反正这里是代码：

Private Sub Userform_Initialize() 
With ListBox1 
.AddItem "100" 
.AddItem "110" 
.AddItem "120" 
End With 

ListBox1.ListIndex = 0 

End Sub 

Private Sub OKButton_Click() 

Dim c As Range 
Dim rRng As Range 
Dim LRow As Range 
Dim rRng2 As Range 
Dim i As Integer 

ChDir "C:\Users\Loff1\Desktop\CreatedBD" 


For i = 0 To ListBox1.ListCount - 1 
If ListBox1.Selected(i) = True Then 
LedAcc = ListBox1.List(i) 


For Each c In Workbooks("Test.xlsx").Sheets("TestBD").Range("A2:A100") 

    If LedAcc = Left(c, 3) Then 

     If rRng Is Nothing Then 
      Set rRng = c 
     Else 
      Set rRng = Application.Union(rRng, c) 
     End If 
    End If 
Next 

Set rRng2 = rRng.Offset(0, 3) 

Workbooks("Test.xlsx").Sheets("TestBD").Select 
Range(rRng, rRng2).Select 
Selection.Copy 

Set NewBook = Workbooks.Add 
NewBook.Sheets("Sheet1").Select 
Range("B9").Select 
ActiveSheet.Paste 

Range("A6").Value = LedAcc 
ThisFile = Range("A6").Value 
NewBook.SaveAs Filename:=ThisFile 
Workbooks(ThisFile & ".xlsx").Close SaveChanges:=False 

End If 

Next i 

End Sub 

Answer 1

我觉得你的问题是在这里：

Range(rRng, rRng2).Select 

你大概意思是这样：

Application.Union(rRng, rRng2).Select 

在我的测试

rRng是A1，A5，A8

rRng2为C1，C5，C8

Range(rRng, rRng2).Select 'results to select range("A1:C1") 

Application.Union(rRng, rRng2).Select 'results to select cells A1,A5,A8,C1,C5,C8 

Offtopic：

让我推荐你使用随着块，不使用选择，但尽量参考范围，而不选择它们：How to avoid using Select in Excel VBA macros

而不是

Workbooks("Test.xlsx").Sheets("TestBD").Select 
Range(rRng, rRng2).Select 
Selection.Copy 

你可以做

With Workbooks("Test.xlsx").Sheets("TestBD") 
    .Range(rRng, rRng2).Copy 
End With 

或

Workbooks("Test.xlsx").Sheets("TestBD").Range(rRng, rRng2).Copy