Posts by Justin Doward

Hi XL,

That can be done by setting the column width to 0 for column A of the listbox, you can use the .columnwidths property in code or just set the column widths seperated by a semicolon in the properties.

HTH

Justin

Hi DA,

An example file would help, it is easier to write a macro to cover existing data. it does not have to include a large dataset, just a representative dataset.

HTH

Justin

Hello WL,

The problem with the way you are using the match function is that match requires ascending order for match type 1 and descending order for match type -1. If you are able to mirror the data some how you might be able to get around this, I will have a look for an alternative solution.

HTH

Justin

Hello MW,

You can achieve your result by copying the cell from excel and right click pasting into the location you desire by selecting copy link and merge formatting. From there it is just a matter of getting the formatting to work. In Options --> advanced -->
General there is the option to have the link update when you open the document.

HTH

Justin

Hello JT,

try the following code:

Option Explicit


Sub FormatMe()
Dim ws1 As Worksheet: Set ws1 = Sheets(1)
Dim ws2 As Worksheet: Set ws2 = Sheets(2)
Dim Irng As Range, Orng As Range
Dim i As Long, j As Long, x As Long
Set Irng = Application.InputBox("Select the table range", Title:="Range Selector", Type:=8)
SetRng:
Set Orng = Application.InputBox("Select the first cell of the output range.", Title:="Range Selector", Type:=8)
If Orng.Rows.Count > 1 Or Orng.Columns.Count > 1 Then
MsgBox "Only select the first cell of the output range."
GoTo SetRng
End If
For i = 1 To 3
Orng.Cells(1, i) = Irng.Cells(1, i)
Next i
Orng.Cells(1, 4) = "Year"
Orng.Cells(1, 5) = "Units"
x = 2
For i = 2 To Irng.Rows.Count
For j = 4 To Irng.Columns.Count
Orng.Cells(x, 1) = Irng.Cells(i, 1)
Orng.Cells(x, 2) = Irng.Cells(i, 2)
Orng.Cells(x, 3) = Irng.Cells(i, 3)
Orng.Cells(x, 4) = Irng.Cells(1, j)
Orng.Cells(x, 5) = Irng.Cells(i, j)
x = x + 1
Next j
Next i
End Sub

HTH

Justin

Hi JB,

There are no changes occurring in the loop, the values all remain the same and subsequently i never changes from a value of I think 342 and the loop is infinite. I am not really sure what you are attempting to do so cannot really help much more.

To see what is going on click on the side of your code so a red mark appears in the border, place this within the loop then press play and the code will stop running at that point. Ensure your locals window is open and the value of all your variables will be there. Press F8 to then step through the code (hold F8 to rapidly move through the loops) I added a counter for the loops (x = x + 1) to keep track, but nothing changes with each iteration.

NB: I have been using VBA a long time and never seen that method of referencing cells before, it is brief but mouse-over with codebreak does not provide the current value, it will also cause problems if you have other than the sheet of interest active (i.e. the code will not know which sheet to reference or I assume that is the case).

HTH

Justin

Hi CO,

I cannot really help with the line 2 error without being able to replicate it, I do not know what would give an error when checking .value2, you could delete the line and test for blanks using the str = x.value2 then as below use if x = vbnullstring then goto Nxt_X... but it may give the same error.

To start on row 2 just enter a goto into the loop:

For Each x In rng
If x.Row = 1 Then GoTo Nxt_X
code here...
Nxt_X:
Next x

Hi AL,

It is related to the way you are filling the listbox in the refresh sub, if you exclude the refresh from the form initialise the problem does not seem to occur.

I am not sure how the .rowsource command works, change it to .additem or .list

Regards

Justin

Hi CO,

Not sure why the first does not work for you, it works fine here.

The second I should have foreseen, sorry about that. I have rewritten to be more specific. If this one needs to be tailored further please upload an example of your data format. Really it is just about defining the range more precisely.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value2 = vbNullString Then GoTo Exit_Sub
If Not Intersect(Target, Range("A:A, C:C")) Is Nothing Then
Const aPath = "http://myurl.default.asp?PopUp1"
Const cPath = "http://myurl.default.asp?PopUp2"
Dim str As String
Dim i As Long, j As Long
Dim rng As Range, x As Range
i = Target.CurrentRegion.Cells(1, 1).Row
j = Target.CurrentRegion.Rows.Count + i - 1
Set rng = Range(Cells(i, Target.Column), Cells(j, Target.Column))
For Each x In rng
str = x.Value2
Select Case Target.Column
Case 1
x.Hyperlinks.Add _
anchor:=x, Address:=aPath & str, _
TextToDisplay:=str
Case 3
x.Hyperlinks.Add _
anchor:=x, Address:=cPath & str, _
TextToDisplay:=str
End Select
Next x
End If
Exit_Sub:
End Sub

Hi CO,

Not sure if this does what you are after, the first only works on the target, the second works through the range depending which range changed.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A, C:C")) Is Nothing Then
Const aPath = "http://myurl.default.asp?PopUp1"
Const cPath = "http://myurl.default.asp?PopUp2"
Dim str As String
str = Target.Value2
Select Case Target.Column
Case 1
Target.Hyperlinks.Add _
anchor:=Target, Address:=aPath & str, _
TextToDisplay:=str
Case 3
Target.Hyperlinks.Add _
anchor:=Target, Address:=cPath & str, _
TextToDisplay:=str
End Select
End If
Exit_Sub:
End Sub

OR

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A, C:C")) Is Nothing Then
Const aPath = "http://myurl.default.asp?PopUp1"
Const cPath = "http://myurl.default.asp?PopUp2"
Dim str As String
Dim rng As Range, x As Range
Set rng = Target.CurrentRegion
For Each x In rng
str = x.Value2
Select Case Target.Column
Case 1
x.Hyperlinks.Add _
anchor:=x, Address:=aPath & str, _
TextToDisplay:=str
Case 3
x.Hyperlinks.Add _
anchor:=x, Address:=cPath & str, _
TextToDisplay:=str
End Select
Next x
End If
Exit_Sub:
End Sub

HTH

Justin

Hi AL,

I have made a small example using your sheet and an alternative approach.

Note, I have only built the article number textbox and the listbox. I have used this site:

The VBA Guide To ListObject Excel Tables

Learn everything there is to know about manipulating and interacting with ListObjects in VBA. Excel Tables are a cornerstone of spreadsheet design. There are…

www.thespreadsheetguru.com

when learning to navigate tables in vba.

NB: As the thread is solved, send me direct if you have any further questions.

Regards

Justin

Hello AL,

The solution to your 2nd problem is here:

SetFocus not working on TextBox after AfterUpdate [SOLVED]

Essentially you need to disable the next textbox in the tab order before setting focus in your code:

txtZoekOpArtBenaming.Enabled = False
txtZoekOpArtNr.SetFocus

then include a sub that re-enables the disabled textbox when setfocus occurs:

Private Sub txtZoekOpArtNr_Enter()
txtZoekOpArtBenaming.Enabled = True
End Sub

This is working for me on the example you sent.

Please note that placing this second question after your first question is not helpful to the forum, particularly as you have not really shown the solution to your first question. No doubt a moderator will draw your attention to the rules and request you read them again.

NB: Good luck with the coding, I like the look of the forms. I would suggest the following if you are open to it:

1.

You are not always using your WITH statements, once you use a with statement you do not then need to name the object again.

2.

I suggest rewriting the code so that very little of it runs from the form code page, rather have code written in the modules and called from the form page. This generally allows you to write code that is more flexible and can be called from multiple locations.

3. you can loop through controls using for example:

with frmKlanten
for i = 1 to 8
.controls("TextBox" & i).value = ""
next i
end with

Best

Justin

Hi AL,

If you are still interested in a solution for this please upload an example workbook with the code not working. It is possible to recreate your sheet and test it, but it would be easier if you had it ready to go.

Regards

Justin

Hi CA,

If a circular reference is required you can allow it in the options, by turning on iterative calculations:

Hello CapG

Not sure why you would not just do this by seperating the text into two columns and using the vlookup function native to excel, but this code should work for the text as provided:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B:B, D:D, E:E")) Is Nothing Then
    Dim rng As Range, c As Range
    Set rng = Range("M3:M6")
        For Each c In rng
            If InStr(c, Target) Then
                Target.Offset(0, 1) = Right(c, 2)
            GoTo Exit_Sub
            End If
        Next c
Exit_Sub:
    End If
End Sub

Hi Jason,

I cannot see how the sheets relate, ID 100000 for example disappears in sheet 3, ID 1040000 repeats on sheet 3 except it has brackets around the negative value and no account is taken of the 1459 that is present on sheet 2. ID 2309D is only on sheet 2 and nowhere else.

Essentially I do not see what is supposed to be occurring.

Hello UA,

Try the attached, the code is as below:

Sub replacement()
Application.ScreenUpdating = False
Dim LOTitle As ListObject
Set LOTitle = Sheet1.ListObjects("Table1")
Dim Arr1, Arr2(), x As Long, y As Long
On Error Resume Next
Arr1 = Application.Transpose(LOTitle.ListColumns(1).DataBodyRange)
ReDim Arr2(UBound(Arr1))
For x = LBound(Arr1) To UBound(Arr1)
'If character in string is not a number or letter the erase it.
For y = Len(Arr1(x)) To 1 Step -1


If Not (Asc(UCase(Mid(Arr1(x), y, 1))) > 64 And Asc(UCase(Mid(Arr1(x), y, 1))) < 91) And _
Not (Asc(Mid(Arr1(x), y, 1)) > 47 And Asc(Mid(Arr1(x), y, 1)) < 58) Then _
Arr1(x) = Replace(Arr1(x), CStr(Mid(Arr1(x), y, 1)), "")
Next y
Next x
'if members of the array are repeated erase all but first iteration.
For x = 1 To UBound(Arr1)
For y = 1 To UBound(Arr1)
If x = y Then GoTo nxtY
If Arr1(x) = Arr1(y) Then Arr1(y) = vbNullString
nxtY:
Next y
Next x
'if arr member not empty copy to new list.
For x = 1 To UBound(Arr1)
If Arr1(x) <> vbNullString Then
y = Sheet1.Cells(Rows.Count, 5).End(xlUp).Row
Sheet1.Cells(y + 1, 5).Value2 = LOTitle.DataBodyRange(x, 1).Value2
Sheet1.Cells(y + 1, 6).Value2 = LOTitle.DataBodyRange(x, 2).Value2
Sheet1.Cells(y + 1, 7).Value2 = LOTitle.DataBodyRange(x, 3).Value2
End If
Next x
Application.ScreenUpdating = True
End Sub

Note that I have made the list an excel table, it is not really necessary just how I have been doing things lately. Just use insert table and highlight your table of interest.

There is an error thrown that I have not worked out, but the resume next corrects it for the list provided, it may be quite slow on your large database so try it on a few hundred/thousand lines first and see how it goes.

Copy of SampleDataMediaList.xlsm

Justin

Hi Splat,

Roy's point is that there is no scenario in which coding to select the cell will be more efficient then just writing to or taking information from the cell directly. Selecting ranges tends to be used by early coders before they learn how to navigate things properly, I believe Roy is trying to determine the overall intent of your coding so he can point you in the right direction but if you are happy that the system does what you are after then stick with it for now, you will probably correct it in the future.

NB: you can easily load a full excel file here and get a working example returned to you where appropriate, i generally would not download and open a zip file.

Glad my earlier post helped!

Cheers

Justin

Hello Splat,

You can use the "Enter" option in the code for the userform:

eg:

Private Sub TextBox1_Enter()
Sheet1.Range("C2").Select
End Sub
Private Sub TextBox2_Enter()
Sheet1.Range("A2").Select
End Sub

Hi MA,

The code you have provided does not really do anything like what you are requesting, is there a reason you are using a combination of system popup and msgbox rather than just using msgbox?

Do you want a message to be displayed when a cell changes or do you want a macro to run through the ranges and popup/msgbox on all values?