Can't execute macro for more than one items from listbox

Question

I am a newbie. I've just written a code which copies a range of cells with looking the first 3 number of the number in the left adjacent column of those cells. For Ex: if the first three number of A1 and A5 is 100 than copy B1:D1 and B5:D5 to a new workbook. At the beginning I was using inputbox to enter the number (100) to find the range that I want to copy. Now I want to use multiple inputs. Like I want to copy cells that are at the right of 100 to a new workbook and cells that are right of 120 to another new workbook with just one code... I wrote a code with using listbox. However the problem is whenever I choose multiple items like 100 110 120 it doesn't work. It copies right adjacent cells of the cells that contains 100 to a new workbook, than again it copies right cells of 100 to another new workbook. I am stuck and waiting for a person to enlight me. Sorry for my english, I am not a native speaker. Anyway here is the code:

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

score 0 · Answer 1 · edited May 23 '17 at 12:12

I think your problem is here:

Range(rRng, rRng2).Select

You probably mean to do this:

Application.Union(rRng, rRng2).Select

in my test

rRng was A1,A5,A8

rRng2 was 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:

let me recommend you to use With blocks and dont use select but try to refer the ranges without selecting them: How to avoid using Select in Excel VBA macros

Instead of

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

You can do

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

or

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

Can't execute macro for more than one items from listbox

1 Answers1