Table editing with excel vba causing crashing and cell lockup - vba

I have made a userform that allows the user to select a table and add rows to it and fill those rows with various information, all from the userform. I have run into a few problems with this.
First after adding or during adding the items (after hitting submit) excel would crash. It occurs randomly and is hard to reproduce.
Second after running the macro there is a good chance that all the cells in the workbook and every other object except the userform button will stop working, meaning you can't edit interact or even select anything. Then when I close the workbook excel crashes after saving. This is my major offender and I think causes the other problem.
What causes this freezing and why does it occur? How do I fix it? I have looked around and haven't found anything circumstantial. One post said that I should try editing the table with no formatting on it and I did that and it didn't work.
I can provide the excel workbook at a request basis via pm.
The code:
On Activate -
Public Sub UserForm_Activate()
Set cBook = ThisWorkbook
Set dsheet = cBook.Sheets("DATA")
End Sub
Help Checkbox -
Private Sub cbHelp_Click()
If Me.cbHelp.Value = True Then
Me.lbHelp.Visible = True
Else
Me.lbHelp.Visible = False
End If
End Sub
Brand combobox -
Public Sub cmbBrand_Change()
brandTableName = cmbBrand.Value
brandTableName = CleanBrandTableName(brandTableName)
'if brand_edit is not = to a table name then error is thrown
On Error Resume Next
If Err = 380 Then
Exit Sub
Else
cmbItemID.RowSource = brandTableName
End If
On Error GoTo 0
'Set cmbItemID's text to nothing after changing to a new brand
cmbItemID.Text = ""
End Sub
CleanBrandTableName(brandTableName) function -
Option Explicit
Public Function CleanBrandTableName(ByVal brandTableName As String) As String
Dim s As Integer
Dim cleanResult As String
For s = 1 To Len(brandTableName)
Select Case Asc(Mid(brandTableName, s, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122:
cleanResult = cleanResult & Mid(brandTableName, s, 1)
Case 95
cleanResult = cleanResult & " "
Case 38
cleanResult = cleanResult & "and"
End Select
Next s
CleanBrandTableName = Replace(WorksheetFunction.Trim(cleanResult), " ", "_")
End Function
Public Function CleanSpecHyperlink(ByVal specLink As String) As String
Dim cleanLink As Variant
cleanLink = specLink
cleanLink = Replace(cleanLink, "=HYPERLINK(", "")
cleanLink = Replace(cleanLink, ")", "")
cleanLink = Replace(cleanLink, ",", "")
cleanLink = Replace(cleanLink, """", "")
cleanLink = Replace(cleanLink, "Specs", "")
CleanSpecHyperlink = cleanLink
End Function
Browse button -
Public Sub cbBrowse_Click()
Dim rPos As Long
Dim lPos As Long
Dim dPos As Long
specLinkFileName = bFile
rPos = InStrRev(specLinkFileName, "\PDFS\")
lPos = Len(specLinkFileName)
dPos = lPos - rPos
specLinkFileName = Right(specLinkFileName, dPos)
Me.tbSpecLink.Text = specLinkFileName
End Sub
bFile function -
Option Explicit
Public Function bFile() As String
bFile = Application.GetOpenFilename(Title:="Please choose a file to open")
If bFile = "" Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
Exit Function
End If
End Function
Preview button -
Private Sub cbSpecs_Click()
If specLinkFileName = "" Then Exit Sub
cBook.FollowHyperlink (specLinkFileName)
End Sub
Add Item button -
Private Sub cbAddItem_Click()
Dim brand As String
Dim description As String
Dim listPrice As Currency
Dim cost As Currency
Dim Notes As String
Dim other As Variant
itemID = Me.tbNewItem.Text
brand = Me.tbBrandName.Text
description = Me.tbDescription.Text
specLink = Replace(specLinkFileName, specLinkFileName, "=HYPERLINK(""" & specLinkFileName & """,""Specs"")")
If Me.tbListPrice.Text = "" Then
listPrice = 0
Else
listPrice = Me.tbListPrice.Text
End If
If Me.tbCost.Text = "" Then
cost = 0
Else
cost = Me.tbCost.Text
End If
Notes = Me.tbNotes.Text
other = Me.tbOther.Text
If Me.lbItemList.listCount = 0 Then
x = 0
End If
With Me.lbItemList
Me.lbItemList.ColumnCount = 8
.AddItem
.List(x, 0) = itemID
.List(x, 1) = brand
.List(x, 2) = description
.List(x, 3) = specLink
.List(x, 4) = listPrice
.List(x, 5) = cost
.List(x, 6) = Notes
.List(x, 7) = other
x = x + 1
End With
End Sub
Submit button -
Private Sub cbSubmit_Click()
Dim n As Long
Dim v As Long
Dim vTable() As Variant
Dim r As Long
Dim o As Long
Dim c As Long
Dim w As Variant
Set brandTable = dsheet.ListObjects(brandTableName)
o = 1
listAmount = lbItemList.listCount
v = brandTable.ListRows.Count
w = 0
For c = 1 To listAmount
If brandTable.ListRows(v).Range(, 1).Value <> "" Then
brandTable.ListRows.Add alwaysinsert:=True
brandTable.ListRows.Add alwaysinsert:=True
Else
brandTable.ListRows.Add alwaysinsert:=True
End If
Next
ReDim vTable(1000, 1 To 10)
For n = 0 To listAmount - 1
vTable(n + 1, 1) = lbItemList.List(n, 0)
vTable(n + 1, 2) = lbItemList.List(n, 1)
vTable(n + 1, 3) = lbItemList.List(n, 2)
vTable(n + 1, 5) = lbItemList.List(n, 4)
vTable(n + 1, 6) = lbItemList.List(n, 5)
vTable(n + 1, 7) = lbItemList.List(n, 6)
vTable(n + 1, 8) = lbItemList.List(n, 7)
If lbItemList.List(n, 3) = "" Then
ElseIf lbItemList.List(n, 3) <> "" Then
vTable(n + 1, 4) = lbItemList.List(n, 3)
End If
If n = 0 And brandTable.DataBodyRange(1, 1) <> "" Then
For r = 1 To brandTable.ListRows.Count
If brandTable.DataBodyRange(r, 1) <> "" Then
o = r + 1
' brandTable.ListRows.Add alwaysinsert:=True
End If
Next
End If
brandTable.ListColumns(1).DataBodyRange(n + o).Value = vTable(n + 1, 1)
brandTable.ListColumns(2).DataBodyRange(n + o).Value = vTable(n + 1, 2)
brandTable.ListColumns(3).DataBodyRange(n + o).Value = vTable(n + 1, 3)
brandTable.ListColumns(4).DataBodyRange(n + o).Value = vTable(n + 1, 4)
brandTable.ListColumns(5).DataBodyRange(n + o).Value = vTable(n + 1, 5)
brandTable.ListColumns(6).DataBodyRange(n + o).Value = vTable(n + 1, 6)
brandTable.ListColumns(7).DataBodyRange(n + o).Value = vTable(n + 1, 7)
brandTable.ListColumns(8).DataBodyRange(n + o).Value = vTable(n + 1, 8)
Next
brandTable.DataBodyRange.Select
Selection.Font.Bold = True
Selection.WrapText = True
brandTable.ListColumns(5).DataBodyRange.Select
Selection.NumberFormat = "$#,##0.00"
brandTable.ListColumns(6).DataBodyRange.Select
Selection.NumberFormat = "$#,##0.00"
Unload Me
End Sub
Remove Items button -
Private Sub cbRemoveItems_Click()
Dim intCount As Long
For intCount = lbItemList.listCount - 1 To 0 Step -1
If lbItemList.Selected(intCount) Then
lbItemList.RemoveItem (intCount)
x = x - 1
End If
Next intCount
End Sub
There is other code that does things for the other tabs but they don't interact with this tabs code.

Related

Is there a way to prevent public variables from reverting to a previous value?

I am using a search and change method using a combo box and buttons, but two important public variables continue to change to zero for no apparent reason.
The aim of the methods is to search for a device type, then search for a specific device and change the value of related cells. It seems to work after the first press of the button, but if the combo box is not changed and a button is pressed, the important variables, OSSstockNum and OSSstartingRowNum, are changed to zero, so the while loop isn't running.
public OSSstockNum As Integer
public OSSstartingRowNum As Integer
Private Sub ComboBox1_Change()
j = 1
OSSfound = False
While j <= Cells(Rows.Count, 2).End(xlUp).Row And OSSfound = False
If Range("B" + CStr(j)).Value = ComboBox1.Value Then
OSSfound = True
Else
j = j + 1
End If
Wend
OSSstockNum = Range("I" + CStr(j)).Value
OSSstartingRowNum = j + 2
End Sub
Private Sub btnFaulty_Click()
Dim intRowNum As Integer
Dim OSSInput As String
Dim CNAddress As String
Dim statusAddress As String
Dim assignAddress As String
Dim condAddress As String
OSSInput = InputBox("What is the Code of the " + ComboBox1.Value + " you
want to change to faulty?")
intRowNum = 0
OSSfound = False
assignAddress = G1
statusAddress = H1
condAddress = I1
While (intRowNum < OSSstockNum And OSSfound = False)
CNAddress = "D" + CStr(OSSstartingRowNum + intRowNum)
If Range(CNAddress).Value = OSSInput Then
OSSfound = True
assignAddress = "G" + CStr(OSSstartingRowNum + intRowNum)
statusAddress = "H" + CStr(OSSstartingRowNum + intRowNum)
condAddress = "I" + CStr(OSSstartingRowNum + intRowNum)
Else
intRowNum = intRowNum + 1
End If
Wend
If OSSfound = True Then
If (Range(statusAddress).Value = "FAULTY") Then
MsgBox ("This device is already faulty")
Else
Range(assignAddress).Value = "FAULTY"
Range(assignAddress).Interior.Color = RGB(255, 199, 206)
Range(assignAddress).Font.Color = RGB(156, 0, 6)
Range(statusAddress).Value = "FAULTY"
Range(statusAddress).Interior.Color = RGB(255, 199, 206)
Range(statusAddress).Font.Color = RGB(156, 0, 6)
Range(condAddress).Value = "FAULTY"
Range(condAddress).Interior.Color = RGB(255, 199, 206)
Range(condAddress).Font.Color = RGB(156, 0, 6)
End If
Else
MsgBox ("Sorry, the device you're looking for couldn't be found")
End If
End Sub
If the input search term is found, it should change the value and formatting of the selected cells, but when the button is pressed a second time, the while loop in the button is being skipped, so true is still false, so it is saying that the device can't be found.

How to correct a userform when error 13 is displayed in VBA?

I'm currently on a project that search in a product database all non-referenced product (blank fields). When I click on the button that opens a userform, error 13 is displayed, here is the code:
Dim i As Integer
Dim j As Integer
Dim t As Integer
Dim r As Integer
t = 1
While Feuil3.Cells(t, 1) <> ""
t = t + 1
Wend
t = t - 1
For r = 2 To t
If Feuil3.Cells(r, 3) = "" Then
i = 1
While Feuil2.Cells(i, 1) <> ""
i = i + 1
Wend
Feuil2.Cells(i, 1) = Feuil3.Cells(r, 2)
End If
Next
i = 1
While Feuil2.Cells(i, 1) <> ""
i = i + 1
Wend
For j = 2 To i
If Feuil2.Cells(j, 2) = "" Then
list51.AddItem Feuil2.Cells(j, 1)
End If
Next
End Sub
It appears that the error comes from this line:If Feuil3.Cells(r, 3) = "" Then
My skills in VBA are limited, do you have any idea on how to fix this problem?
Thanks,
Have a look at this. Should do the same just a lot less iteratively
Dim Feuil2Rng As Range, Feuil3Rng As Range
Dim c
With Feuil3
Set Feuil3Rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
End With
For Each c In Feuil3Rng
If c.Offset(0, 2) = vbNullString Then
With Feuil2
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) = c.Offset(0,1)
End With
End If
Next
With Feuil2
Set Feuil2Rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
End With
For Each c In Feuil2Rng
If c.Offset(0, 1) = vbNullString Then
list51.AddItem c.Value2
End If
Next

SlideShowWindows error (integer out of range)

I'm preparing a quiz using on PowerPoint using the controllers of VBA scripts. My aim to set multiple questions, each has 4 choices.
I've set everything, when trying to run (starting with the method: "BeginQuiz") it's interrupted by the following error:
SlideShowWindows (unknown number) Integer out of range
My code is below:
Const NOOFQS = 4
'Used to manipulated the unicode values of bulleted lists
Const UD_CODE_1 = 111
Const UD_CODE_2 = 8226
Public QNo As Integer
Public ExitFlag As Boolean
Public Qs() As String
Public Choices() As String
Public Ans() As Integer
Public UserAns() As Integer
Sub NextSlide()
' Store the ans for later
'UserAns(QNo - 1) = 1
If QNo < NOOFQS Then
QNo = QNo + 1
SlideShowWindows(1).Presentation.Slides("QSlide").Shapes(1).TextFrame.TextRange.Text = Qs(QNo - 1)
AssignValues
Else
Call StopQuiz
End If
DoEvents
End Sub
Sub PreviousSlide()
Static X As Integer
If QNo > 1 Then
QNo = QNo - 1
AssignValues
End If
End Sub
Sub StopQuiz(Optional EndType As Boolean = False)
' EndType is used as a boolean Flag to indicate whether the user ran out of time
' or whether it was normal exit
Dim ScoreCard As Integer
Dim Ctr As Integer
ExitFlag = True
With SlideShowWindows(1)
For Ctr = 0 To NOOFQS - 1
If Ans(Ctr) = UserAns(Ctr) Then ScoreCard = ScoreCard + 1
Next Ctr
If EndType = False Then
.Presentation.Slides("EndSlide").Shapes("Closing").TextFrame.TextRange.Text = "Your score is : " & ScoreCard & " correct out of " & NOOFQS
Else
.Presentation.Slides("EndSlide").Shapes("Closing").TextFrame.TextRange.Text = "Sorry!!! Either you ran out of time or you chickened out" _
& vbCrLf & "Better luck next time." & vbCrLf _
& "Your score is: " & ScoreCard & " correct out of " & NOOFQS
End If
.View.GotoSlide (.Presentation.Slides("EndSlide").SlideIndex)
End With
End Sub
Sub StopIt()
Call StopQuiz(True)
End Sub
Sub BeginQuiz()
Dim Ctr As Integer
ReDim Qs(NOOFQS)
ReDim Ans(NOOFQS)
ReDim UserAns(NOOFQS)
ReDim Choices(NOOFQS, 4)
' All the questions
Qs(0) = "1) ãä Ãæá ãä ÝÊÍ ÇáÞÏÓ ÈÚÏ ÚãÑ¿"
Qs(1) = "2) ãä åí Ãæá ãä ÃÓáãÊ ãä ÇáäÓÇÁ¿"
Qs(2) = "3) ãÇ åí ÇáãäØÞÉ ÇáÊí ÍÑÑåÇ ãÍãÏ ÇáÝÇÊÍ¿"
Qs(3) = "4) ãÇ åæ Ãæá ãÓÌÏ Ýí ÇáÅÓáÇã¿"
' Set all user answers to negative
For Ctr = 0 To NOOFQS - 1
UserAns(Ctr) = -1
Next Ctr
' All the choices 3 each for a question
Choices(0, 0) = " ÕáÇÍ ÇáÏíä ÇáÃíæÈí"
Choices(0, 1) = " ÇáÞÇÆÏ ÇáãÙÝÑ"
Choices(0, 2) = " ÎÇáÏ Èä ÇáæáíÏ"
Choices(0, 3) = " ÇáÙÇåÑ ÈíÈÑÓ"
Choices(1, 0) = " ÃÓãÇÁ ÈäÊ ÃÈí ÈßÑ "
Choices(1, 1) = " ÓæÏÉ ÈäÊ ÒãÚÉ "
Choices(1, 2) = " ÎÏíÌÉ ÈäÊ ÎæíáÏ "
Choices(1, 3) = " Ãã ÚãÇÑ Èä íÇÓÑ "
Choices(2, 0) = " ØáíØáÉ "
Choices(2, 1) = " ÇáÞÇÏÓíÉ "
Choices(2, 2) = " ÇáÞÓØäØíäíÉ "
Choices(2, 3) = " ÇáÃäÏáÓ"
Choices(3, 0) = " ãÓÌÏ ÞÈÇÁ"
Choices(3, 1) = " ãÓÌÏ Ðí ÇáäæÑíä"
Choices(3, 2) = " ÇáãÓÌÏ ÇáäÈæí"
Choices(3, 3) = " ÇáÈíÊ ÇáÍÑÇã"
' Provide the answer list here.
' Ans(0) = 0 means that the correct answer to the 1st question is the 1st choice.
' Ans(1) = 1 means that the correct answer to the 2nd question is the 2nd choice.
' Ans(2) = 1 means that the correct answer to the 3rd question is the 2nd choice.
Ans(0) = 0
Ans(1) = 2
Ans(2) = 2
Ans(3) = 0
QNo = 1
AssignValues
With SlideShowWindows(1)
.View.GotoSlide (.Presentation.Slides("QSlide").SlideIndex)
End With
' Comment the line below to stop the timer.
Call Tmr
End Sub
Sub SetBulletUnicode(ShapeName As String, Code As Integer)
With SlideShowWindows(1).Presentation.Slides("QSlide").Shapes(ShapeName).TextFrame.TextRange.ParagraphFormat.Bullet
.UseTextFont = msoTrue
.Character = Code
End With
End Sub
Sub ButtonChoice1()
UserAns(QNo - 1) = 0
AssignValues
End Sub
Sub ButtonChoice2()
UserAns(QNo - 1) = 1
AssignValues
End Sub
Sub ButtonChoice3()
UserAns(QNo - 1) = 2
AssignValues
End Sub
Sub Tmr()
'Just in the eventuality that you click the start button twice
'isRunning stores the current state of the macro
'TRUE = Running; FALSE = Idle
ExitFlag = False
Static isRunning As Boolean
If isRunning = True Then
End
Else
isRunning = True
Dim TMinus As Integer
Dim xtime As Date
xtime = Now
With ActivePresentation.Slides(2).Shapes("Timer")
'Countdown in seconds
TMinus = 59
Do While (TMinus > -1)
DoEvents
' Rather crude way to determine if a second has elapsed
If ExitFlag = True Then
.TextFrame.TextRange.Text = "00:00:00"
isRunning = False
Exit Sub
End If
If Format(Now, "ss") <> Format(xtime, "ss") Then
xtime = Now
.TextFrame.TextRange.Text = Format(TimeValue(Format(Now, "hh:mm:ss")) - _
TimeSerial(Hour(Now), Minute(Now), Second(Now) + TMinus), "hh:mm:ss")
TMinus = TMinus - 1
' Let the display refresh itself
End If
Loop
End With
Debug.Print "came here"
isRunning = False
StopQuiz True
End
End If
End Sub
Sub AssignValues()
SetBulletUnicode "Choice1", UD_CODE_1
SetBulletUnicode "Choice2", UD_CODE_1
SetBulletUnicode "Choice3", UD_CODE_1
SetBulletUnicode "Choice4", UD_CODE_1
Select Case UserAns(QNo - 1)
Case 0
SetBulletUnicode "Choice1", UD_CODE_2
Case 1
SetBulletUnicode "Choice2", UD_CODE_2
Case 2
SetBulletUnicode "Choice3", UD_CODE_2
Case 3
SetBulletUnicode "Choice4", UD_CODE_2
End Select
With SlideShowWindows(1).Presentation.Slides("QSlide")
.Shapes(1).TextFrame.TextRange.Text = Qs(QNo - 1)
.Shapes("Choice1").TextFrame.TextRange.Text = Choices(QNo - 1, 0)
.Shapes("Choice2").TextFrame.TextRange.Text = Choices(QNo - 1, 1)
.Shapes("Choice3").TextFrame.TextRange.Text = Choices(QNo - 1, 2)
.Shapes("Choice4").TextFrame.TextRange.Text = Choices(QNo - 1, 3)
End With
End Sub
Sub ShowAnswers()
Dim AnsList As String
AnsList = "The answers are as follows:" & vbCrLf
For X = 0 To NOOFQS - 1
AnsList = AnsList & Qs(X) & vbTab & " Answer:" & Choices(X, Ans(X)) & vbCrLf
Next X
MsgBox AnsList, vbOKOnly, "Correct answers"
End Sub

Excel Search VBA macro

I have been given the task of searching through a large volume of
data. The data is presented identically across around 50 worksheets. I
need a macro which searches through all these sheets for specific
values then copies certain cells to a table created in a new workbook.
The macro also needs to create the table headings when it is run.
It must Search column G For the Value 9.1 Then certain information
must be copied to corresponding columns in the table
FHA Ref = Same row value from column G
Engine Effect = Same row value from column F
Part Number = Always cell J3
Part Name = Always cell C2
FM ID = Same Row value from Column B
Failure Mode & Cause = Same Row Value from Column C
FMCN = Same Row Value From Column C"`
If it is a hassle to create the new workbook with these column
headings then I would be quite happy to create the headings myself in
the worksheet and just have the macro search for and copy the data to
the rows corresponding to the headings.
If any help or backup files are needed I would be more than happy to
provide these.
the code I have at the moment is based on a userform also ideally I would do away with this and just search all sheets
Public Sub createWSheet(module, srcWBook)
Dim i
i = 0
srcWB = srcWBook
For Each ws In Workbooks(srcWBook).Worksheets
i = i + 1
If ws.Name = module Then
MsgBox ("A worksheet with for this module already exists")
Exit Sub
End If
Next ws
Workbooks(srcWBook).Activate
Worksheets.Add after:=Worksheets(i)
ActiveSheet.Name = module
Cells(2, 2) = "FHA Ref"
Cells(2, 3) = "Engine Effect"
Cells(2, 4) = "Part No"
Cells(2, 5) = "Part Name"
Cells(2, 6) = "FM ID"
Cells(2, 7) = "Failure Mode & Cause"
Cells(2, 8) = "FMCN"
Cells(2, 9) = "PTR"
Cells(2, 10) = "ETR"
Range(Cells(2, 2), Cells(2, 10)).Font.Bold = True
Range(Cells(1, 2), Cells(1, 10)) = "Interface"
Range(Cells(1, 2), Cells(1, 10)).MergeCells = True
Range(Cells(1, 2), Cells(1, 10)).Font.Bold = True
Workbooks(srcWBook).Activate
End Sub
Dim mainWB, srcWBook
Dim headerLeft, headerTop, headerBottom, headerRight
Dim nTargetFMECA, nPartID, nLineID, nPartNo, nPartName, nQTY, nFailureMode, nAssumedSystemEffect, nAssumedEngineEffect
Dim item As String
Dim mDest
Dim selections(100)
Public Sub controlCopyFMs(mWB, sWB, module)
Dim i
mainWB = mWB
srcWBook = sWB
mDest = 2
nTargetFMECA = 0
nPartID = 0
nLineID = 0
nPartNo = 0
nPartName = 0
nQTY = 0
nFailureMode = 0
nAssumedSystemEffect = 0
nAssumedEngineEffect = 0
For i = 0 To TestForm.LBSelected.ListCount - 1
Call copyFMs(module, selections(i))
Next i
End Sub
Public Sub copyFMs(module, comp)
Dim mSrc
Workbooks(srcWBook).Sheets(comp).Select
If exploreHeader(comp) = 0 Then
Exit Sub
End If
mSrc = headerBottom + 3
While Cells(mSrc, nSrc).Text <> ""
If Cells(mSrc, nIndication).Text <> "-" Then
If Cells(mSrc, nIndication).Text <> "" Then
Workbooks(mainWB).Worksheets(module).Cells(mDest, 2) = Cells(mSrc, nTargetFMECA).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 3) = Cells(mSrc, nPartID).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 4) = Cells(mSrc, nLineID).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 5) = Cells(mSrc, nPartNo).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 6) = Cells(mSrc, nPartName).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 7) = Cells(mSrc, nQTY).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 8) = Cells(mSrc, nFailureMode).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 9) = Cells(mSrc, nAssumedEngineEffect).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 10) = Cells(mSrc, nAssumedSystemEffect).Value
mDest = mDest + 1
End If
End If
mSrc = mSrc + 2
Wend
End Sub
Public Function exploreHeader(comp)
Dim m, n
m = 1
n = 1
While ((InStr(1, Cells(m, n).Text, "Engine Programme:", vbTextCompare) <= 0) Or (InStr(1, Cells(m, n).Text, "BR700-725", vbTextCompare) <= 0)) And n < 10
If m < 10 Then
m = m + 1
Else
n = n + 1
m = 1
End If
Wend
headerTop = m
headerLeft = n
While StrComp(Cells(m, n).Text, "ID", vbTextCompare) <> 0 And StrComp(Cells(m, n).Text, "Case No.", vbTextCompare) <> 0
m = m + 1
Wend
headerBottom = m - 1
While Cells(m, n).Borders(xlEdgeBottom).LineStyle = xlContinuous
n = n + 1
Wend
headerRight = n - 1
m = headerTop
n = headerLeft
Do
If n > headerRight Then
n = headerLeft
m = m + 1
End If
If InStr(1, Cells(m, n).Value, "Item No.:", vbTextCompare) > 0 Then
item = Right(Cells(m, n).Value, Len(Cells(m, n).Value) - InStr(1, Cells(m, n).Value, ":", vbTextCompare))
Cells(m, n).Select
Exit Do
End If
n = n + 1
Loop While m <= headerBottom
m = headerBottom + 1
n = headerLeft
While n <= headerRight
If StrComp(Cells(m, n).Value, "ID", vbTextCompare) = 0 Then
nID = n
End If
If StrComp(Cells(m, n).Value, "Mitigation", vbTextCompare) = 0 Then
nMitigation = n
End If
If StrComp(Cells(m, n).Value, "Remarks", vbTextCompare) = 0 Then
nRemarks = n
End If
If StrComp(Cells(m, n).Value, "FMCN", vbTextCompare) = 0 Then
nFMCN = n
End If
If StrComp(Cells(m, n).Value, "Indication", vbTextCompare) = 0 Then
nIndication = n
End If
If StrComp(Cells(m, n).Value, "Crit", vbTextCompare) = 0 Then
nFMCN = n
End If
If StrComp(Cells(m, n).Value, "Detect", vbTextCompare) = 0 Then
nIndication = n
End If
If StrComp(Cells(m, n).Value, "Functional Description", vbTextCompare) = 0 Then
nMitigation = n
End If
n = n + 1
Wend
exploreHeader = 1
End Function
Public Sub initSelections()
For i = 0 To 99
selections(i) = ""
Next i
End Sub
Public Sub loadSelection(comp, i)
selections(i) = comp
End Sub
Public Sub deleteSelection(i)
While selections(i) <> ""
selections(i) = selections(i + 1)
i = i + 1
Wend
End Sub
I hope this can help more. This code may not work 100% but it should be good enough to guide you. Let me know if you have questions.
Dim WS As Worksheet
Dim Results(7, 1000000) As String ''Didn't know what is a good data type or how many possible results
Dim ColValue() As Variant
Dim I, II, ResultCt As Long
ResultCt = 0
For Each WS In ActiveWorkbook.Worksheets ''This should get all your result and information into the Results Array
ColValue = ActiveSheet.Range(Cells(2, 7), Cells(WS.UsedRange.Rows.Count, 7)).Value ''This put all of column G into an array
For I = 0 To UBound(ColValue)
If ColValue(I, 1) = "9.1" Then
Results(0, ResultCt) = Cells(I + 1, 7).Value ''I think it is off by 1, but if not remove the +1
Results(1, ResultCt) = Cells(I + 1, 6).Value
Results(2, ResultCt) = Cells(3, 10).Value
Results(3, ResultCt) = Cells(2, 3).Value
Results(4, ResultCt) = Cells(I + 1, 2).Value
Results(5, ResultCt) = Cells(I + 1, 3).Value
Results(6, ResultCt) = Cells(I + 1, 3).Value
ResultCt = ResultCt + 1
End If
Next
Next WS
''At this point us your code to create the worksheet and name it
''starting from the line Workbooks(srcWBook).Activate
''Then Set the Active cell to where ever you want to start putting the data and have something like
For I = 0 To UBound(Results, 2)
For II = 0 To UBound(Results)
ActiveCell.Offset(I, II).Value = Results(I, II) ''This assumes you put the information into Result in the order you want it printed out
Next
Next

VBA realtime filter Listbox through Textbox

I would like to filter a Listbox created from a list of values stored in a worksheet depending on text written in a textbox contained in the same userform.
My Listbox has 4 or 5 columns (depending on OptionField selection) and I would like to search all the columns for the text written.
Example: I write "aaa" in TextField and the Listbox should return a list based on all the lines whose column 1 or 2 or 3 or 4 or 5 contain "aaa".
Below my code to refresh the list on OptionField selection (this code does not produce any error, it is just to show how I create my list):
Sub RefreshList()
Dim selcell, firstcell As String
Dim k, i As Integer
Dim r as long
i = 0
k = 0
' reads parameters from hidden worksheet
If Me.new_schl = True Then
firstcell = Cells(3, 4).Address
selcell = firstcell
Do Until IsEmpty(Range("" & selcell & "")) And i = 2
If IsEmpty(Range("" & selcell & "")) Then i = i + 1
k = k + 1
selcell = Cells(1 + k, 7).Address(0, 0)
Loop
k = k - 1
selcell = Cells(1 + k, 7).Address(0, 0)
With Me.ListBox1
.ColumnCount = 4
.ColumnWidths = "50; 80; 160; 40"
.RowSource = ""
Set MyData = Range("" & firstcell & ":" & selcell & "")
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 3) = "" Or .List(r, 3) = "0" Then
.RemoveItem r
End If
Next r
End With
Else
firstcell = Cells(3, 11).Address
selcell = firstcell
Do Until IsEmpty(Range("" & selcell & "")) And i = 11
If IsEmpty(Range("" & selcell & "")) Then i = i + 1
k = k + 1
selcell = Cells(1 + k, 15).Address(0, 0)
Loop
k = k - 1
selcell = Cells(1 + k, 15).Address(0, 0)
With Me.ListBox1
.ColumnCount = 5
.ColumnWidths = "40; 40; 160; 40; 40"
.RowSource = ""
Set MyData = Range("" & firstcell & ":" & selcell & "")
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 3) = "" Or .List(r, 3) = "0" Then
.RemoveItem r
End If
Next r
End With
End If
End Sub
Finally I could come out with something!
Sub Filter_Change()
Dim i As Long
Dim Str As String
Str = Me.Filter.Text
Me.RefreshList
If Not Str = "" Then
With Me.ListBox1
For i = .ListCount - 1 To 0 Step -1
If InStr(1, LCase(.List(i, 0)), LCase(Str)) = 0 And InStr(1, LCase(.List(i, 1)), LCase(Str)) = 0 And _
InStr(1, LCase(.List(i, 2)), LCase(Str)) = 0 And InStr(1, LCase(.List(i, 3)), LCase(Str)) = 0 Then
.RemoveItem i
End If
Next i
End With
End If
End Sub
I know, the answer is couple of years old...
But I thought I'd share solution that works the best for me, because the filter is blazing fast even when there are thousands of items in the list. It is not without a "catch", though:
it uses a Dictionary object
Option Explicit
Dim myDictionary As Scripting.Dictionary
Private Sub fillListbox()
Dim iii As Integer
Set myDictionary = New Scripting.Dictionary
' this, here, is just a "draft" of a possible loop
' for filling in the dictionary
For iii = 1 To RANGE_END
If Not myDictionary.Exists(UNIQUE_VALUE) Then
myDictionary.Add INDEX, VALUE
End If
Next
myListbox.List = myDictionary .Items
End Sub
Private Sub textboxSearch_Change()
Dim Keys As Variant
Keys = myDictionary .Items
myListbox.List = Filter(Keys, textboxSearch.Text, True, vbTextCompare)
End Sub
Private Sub UserForm_Initialize()
Call fillListbox
End Sub