filter and copy data from another workbook based on selection from listbox

[Prashant1211]

Dear All,

I already have below code which imports data from another workbook, but this copies complete range which i dont need. my expectation is as below -

when i select file to import data from

- a Listbox appears which picks unique items from Sheet1.Range("A") of selected file.
- from the unique item list, i can select the required items (multiple items)
- with command button complete rows of items selected gets copied in my other workbook.

if anyone can help me in the code please.

so far i use below code which copies the data and then i manually delete all rows which are not required.
On Error Resume Next

Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim LastRow As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen = False Then Exit Sub
Set OpenBook = Application.Workbooks.Open(FileToOpen)
LastRow = ActiveSheet.UsedRange.Rows.Count
OpenBook.Sheets(1).Range("A1:J1" & LastRow).Copy
ThisWorkbook.Worksheets("Main Sheet").Activate
Sheets.Add(After:=Sheets("Main Sheet")).Name = "Sheet1"
Sheets("Sheet1").Select
ActiveSheet.Paste

 

[Prashant1211]

anyone can help me ?

 

[I_know_nuffin]

anyone can help me ?

Hi

I would do this a different way

As you are now doing import the data to your worksheet, and then populate the list box from this sheet

below will do the job

for testing i used

sheet name = sheet_test
listbox = LB1

its based on data in column C being used for the unique range

Sub load_listbox_and_delete_rows()


' below code works based on a sheet named "sheet_test" with a listbox in the sheet called LB1


Dim rowcount As Long, vfind As String
Dim v()
Dim deleterows() As Integer
Range("A1").Select
rowcount = Selection.End(xlDown).Row

ReDim deleterows(rowcount)

' populate the list box based on Column C
v = getUniqueArray(Range("C2:C" & rowcount))


' add unique items to listbox
With Sheets("Sheet_Test").LB1
For x = 1 To UBound(v)
.AddItem v(x, 1)
Next x
End With


'stop added to select items from list box

Stop

'select items in listbox

' print items selected to immediate window
With Sheets("Sheet_Test").LB1
For x = 0 To .ListCount - 1

      If .Selected(x) = True Then
         Debug.Print .List(x)
         
         vfind = .List(x)
         
        With Sheets("Sheet_Test").Range("C1:C" & rowcount)
        Set c = .Find(vfind, LookIn:=xlValues)
        If Not c Is Nothing Then
        firstAddress = c.Address
            'Debug.Print firstAddress
            Do
                ' change the value in the selected cell otherwise it doesnt move to the next cell
                c.Value = "Delete me"
                'Debug.Print c.Row 'c.Address
                
                ' add row number to the delete array
                deleterows(c.Row) = 1
                
                Set c = .FindNext(c)
                
            Loop While Not c Is Nothing
        End If
    End With
    End If

   Next x


Call Fdeleterows(deleterows)


'empty listbox
.Clear
End With

End Sub


Function Fdeleterows(deleterows() As Integer)

For x = UBound(deleterows) To 1 Step -1
Debug.Print x, deleterows(x)
If deleterows(x) = 1 Then
Rows(x).Delete xlUp
End If
Next x
End Function



Public Function getUniqueArray(inputRange As Range, _
                                Optional skipBlanks As Boolean = True, _
                                Optional matchCase As Boolean = True, _
                                Optional prepPrint As Boolean = True _
                                ) As Variant
               
Dim vDic As Object
Dim tArea As Range
Dim tArr As Variant, tVal As Variant, tmp As Variant
Dim noBlanks As Boolean
Dim cnt As Long
                      
On Error GoTo exitFunc:
If inputRange Is Nothing Then GoTo exitFunc

With inputRange
    If .Cells.Count < 2 Then
        ReDim tArr(1 To 1, 1 To 1)
        tArr(1, 1) = .Value2
        getUniqueArray = tArr
        GoTo exitFunc
    End If

    Set vDic = CreateObject("scripting.dictionary")
    If Not matchCase Then vDic.compareMode = vbTextCompare
    
    noBlanks = True
    
    For Each tArea In .Areas
        tArr = tArea.Value2
        For Each tVal In tArr
            If tVal <> vbNullString Then
                vDic.Item(tVal) = Empty
            ElseIf noBlanks Then
                noBlanks = False
            End If
        Next
    Next
End With

If Not skipBlanks Then If Not noBlanks Then vDic.Item(vbNullString) = Empty

'this is done just in the case of large data sets where the limits of
'transpose may be encountered
If prepPrint Then
    ReDim tmp(1 To vDic.Count, 1 To 1)
    For Each tVal In vDic.Keys
        cnt = cnt + 1
        tmp(cnt, 1) = tVal
    Next
    getUniqueArray = tmp
Else
    getUniqueArray = vDic.Keys
End If

exitFunc:
Set vDic = Nothing
End Function

 

[Prashant1211]

Hi I_know_nuffin
Many thanks for your help.

 

[Prashant1211]

Hi

I would do this a different way

As you are now doing import the data to your worksheet, and then populate the list box from this sheet

below will do the job

for testing i used

sheet name = sheet_test
listbox = LB1

its based on data in column C being used for the unique range

Sub load_listbox_and_delete_rows()


' below code works based on a sheet named "sheet_test" with a listbox in the sheet called LB1


Dim rowcount As Long, vfind As String
Dim v()
Dim deleterows() As Integer
Range("A1").Select
rowcount = Selection.End(xlDown).Row

ReDim deleterows(rowcount)

' populate the list box based on Column C
v = getUniqueArray(Range("C2:C" & rowcount))


' add unique items to listbox
With Sheets("Sheet_Test").LB1
For x = 1 To UBound(v)
.AddItem v(x, 1)
Next x
End With


'stop added to select items from list box

Stop

'select items in listbox

' print items selected to immediate window
With Sheets("Sheet_Test").LB1
For x = 0 To .ListCount - 1

      If .Selected(x) = True Then
         Debug.Print .List(x)
        
         vfind = .List(x)
        
        With Sheets("Sheet_Test").Range("C1:C" & rowcount)
        Set c = .Find(vfind, LookIn:=xlValues)
        If Not c Is Nothing Then
        firstAddress = c.Address
            'Debug.Print firstAddress
            Do
                ' change the value in the selected cell otherwise it doesnt move to the next cell
                c.Value = "Delete me"
                'Debug.Print c.Row 'c.Address
               
                ' add row number to the delete array
                deleterows(c.Row) = 1
               
                Set c = .FindNext(c)
               
            Loop While Not c Is Nothing
        End If
    End With
    End If

   Next x


Call Fdeleterows(deleterows)


'empty listbox
.Clear
End With

End Sub


Function Fdeleterows(deleterows() As Integer)

For x = UBound(deleterows) To 1 Step -1
Debug.Print x, deleterows(x)
If deleterows(x) = 1 Then
Rows(x).Delete xlUp
End If
Next x
End Function



Public Function getUniqueArray(inputRange As Range, _
                                Optional skipBlanks As Boolean = True, _
                                Optional matchCase As Boolean = True, _
                                Optional prepPrint As Boolean = True _
                                ) As Variant
              
Dim vDic As Object
Dim tArea As Range
Dim tArr As Variant, tVal As Variant, tmp As Variant
Dim noBlanks As Boolean
Dim cnt As Long
                     
On Error GoTo exitFunc:
If inputRange Is Nothing Then GoTo exitFunc

With inputRange
    If .Cells.Count < 2 Then
        ReDim tArr(1 To 1, 1 To 1)
        tArr(1, 1) = .Value2
        getUniqueArray = tArr
        GoTo exitFunc
    End If

    Set vDic = CreateObject("scripting.dictionary")
    If Not matchCase Then vDic.compareMode = vbTextCompare
   
    noBlanks = True
   
    For Each tArea In .Areas
        tArr = tArea.Value2
        For Each tVal In tArr
            If tVal <> vbNullString Then
                vDic.Item(tVal) = Empty
            ElseIf noBlanks Then
                noBlanks = False
            End If
        Next
    Next
End With

If Not skipBlanks Then If Not noBlanks Then vDic.Item(vbNullString) = Empty

'this is done just in the case of large data sets where the limits of
'transpose may be encountered
If prepPrint Then
    ReDim tmp(1 To vDic.Count, 1 To 1)
    For Each tVal In vDic.Keys
        cnt = cnt + 1
        tmp(cnt, 1) = tVal
    Next
    getUniqueArray = tmp
Else
    getUniqueArray = vDic.Keys
End If

exitFunc:
Set vDic = Nothing
End Function

Hi, please suggest what to change in above code if I want to keep the selected rows from List box and delete the remaining ?
also how to run the code once it stops for listbox value selection. I tried pressing enter after selection but it didnt worked. should I use a button to proceed, can you please guide ?

Thanks a lot

 

[I_know_nuffin]

to continue the code press F5 or select Run from the VBA window menu options

to change the code to delete the unselected items

change
If .Selected(x) = True Then
to
If .Selected(x) = False Then