Hi prakash,
First, I had to rename your books, having a book named List Box can easily lead to errors...They're now named "ListBook" and "ListBookData".
I looked at several ways of doing this and decided the easiest way to go about it was to have a workbook open event to open "ListBookData" and copy the data in an unused part of the sheet (I chose columns AA, AB, AC, and AD) then delete all this copied data from the ListBook with a before close event. So this code goes in the "ThisWorkbook" module:
'//"ThisWorkbook" module code
Option Explicit
Private Sub Workbook_Open()
Application.ScreenUpdating = False
On Error Resume Next '<< if book is already open
Application.Workbooks.Open(ThisWorkbook.Path & "/ListBookData").Activate
'//open ListBookData following your path
'Application.Workbooks.Open("G:/Desktop NT/VBA/EXAMPLES" & _
"/ListBookData.xls").Activate
Windows("ListBookData.xls").Activate
Columns("A:D").Select
Selection.Copy
Windows("ListBook.xls").Activate
Columns("AA:AD").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWindow.LargeScroll Down:=-10
ActiveWindow.LargeScroll ToRight:=-10
Range("A1").Select
Workbooks("ListBookData.xls").Close
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.ScreenUpdating = False
Columns("AA:AD").Select
With Selection
.ClearContents
.Interior.ColorIndex = xlNone
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End Sub
And this code goes into the UserForm module:
'//"UserForm1" module code
Option Explicit
Public Chosen$
Private Sub UserForm_Activate()
Dim MyList(50, 4), M%, N%
With ListBox1
.ColumnCount = 4
.ColumnWidths = "35pt;35pt;35pt;35pt"
.Width = 160
.Height = 120
.BoundColumn = 1
End With
DoEvents
Application.ScreenUpdating = False
For N = 1 To 50
M = N - 1
With ActiveSheet
'//put the entire selection in list box
MyList(M, 0) = Range("AA" & N)
MyList(M, 1) = Range("AB" & N)
MyList(M, 2) = Range("AC" & N)
MyList(M, 3) = Range("AD" & N)
End With
Next N
ListBox1.List = MyList()
End Sub
Private Sub optFloor_Click()
If optFloor = True Then
Chosen = "Floor"
DoShortList
End If
End Sub
Private Sub optRoof_Click()
If optRoof = True Then
Chosen = "Roof"
DoShortList
End If
End Sub
Private Sub optWall_Click()
If optWall = True Then
Chosen = "Wall"
DoShortList
End If
End Sub
Private Sub DoShortList()
Dim MyList(50, 4), N%
'//(n.b. listbox size etc. is setup on "UserForm_Activate")
Application.ScreenUpdating = False
With ActiveSheet
'//put headings in list box
MyList(0, 0) = Range("AA1")
MyList(0, 1) = Range("AB1")
MyList(0, 2) = Range("AC1")
MyList(0, 3) = Range("AD1")
End With
Range("AA2").Activate
N = 1
Do Until Selection = Empty
'//put selected type in list box
If ActiveCell.Offset(0, 1) = Chosen Then
MyList(N, 0) = ActiveCell
MyList(N, 1) = ActiveCell.Offset(0, 1)
MyList(N, 2) = ActiveCell.Offset(0, 2)
MyList(N, 3) = ActiveCell.Offset(0, 3)
N = N + 1
End If
ActiveCell.Offset(1, 0).Activate
Loop
ListBox1.List = MyList()
End Sub
Private Sub cmdInsert_Click()
'//inserts the required data where you wanted it
Dim MyList(50, 4), M%, N%
If optFloor = False And optWall = False And _
optRoof = False Then GoTo IsError
Application.ScreenUpdating = False
'//copy and paste heading
Range("AA1:AD1").Select
Selection.Copy
If Range("A1") = Empty Then
Range("A1").Select
Else
Range("A65536").End(xlUp).Offset(11, 0).Select
End If
ActiveSheet.Paste
'//now put the data below this
Range("AA2").Activate
N = 1
Do Until Selection = Empty
'//put selected type on sheet
If ActiveCell.Offset(0, 1) = Chosen Then
Range("A65536").End(xlUp).Offset(1, 0) = ActiveCell
Range("B65536").End(xlUp).Offset(1, 0) = ActiveCell.Offset(0, 1)
Range("C65536").End(xlUp).Offset(1, 0) = ActiveCell.Offset(0, 2)
Range("D65536").End(xlUp).Offset(1, 0) = ActiveCell.Offset(0, 3)
N = N + 1
End If
ActiveCell.Offset(1, 0).Activate
Loop
'//put the borders in
Range("A65536").End(xlUp).Activate
ActiveCell.CurrentRegion.Select
Application.CutCopyMode = False
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
IsError:
Range("A1").Select
Unload Me
End Sub
The "G" drive had me foxed for a while, try this and if you get any more range reference errors use your original references.
Regards,
John