Posts by Justin Doward

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?

Hi Mamun,

You can try the approach in the attachment: Book1.xlsm

I am not sure if you know how to navigate the code?

there is code on the worksheet:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("G9:G1200")) Is Nothing Then
If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then GoTo Exit_Sub
UserForm1.Show
End If
Exit_Sub:
End Sub

Modify the range G9:G1200 as required.

the this code attached to the userform:

Option Explicit


Private Sub ListBox1_Click()
ActiveCell.Value = Me.ListBox1.Value
Unload Me
End Sub


Private Sub UserForm_Activate()
Dim LOList As ListObject
Dim ws As Worksheet: Set ws = Sheet1
Set LOList = ws.ListObjects("Table1")
Dim ArrList As Variant
ArrList = Application.Transpose(LOList.DataBodyRange)
UserForm1.ListBox1.List = ArrList
End Sub

Just create your list of terms, insert it as a table (with header) and name it then change ws = sheet1 to refer to whichever sheet your table is one, and the Table1 to be whatever you name your table and it should work in whatever context you need.

Let me know how it goes.

JD

You can replace the code in the workbook_SheetChange event with:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range)
If Not Intersect(Sh.Range(target.Address), Sh.Range("C7:U41")) Is Nothing Then
Application.ScreenUpdating = False
Call background_color_count
Application.ScreenUpdating = True
End If
End Sub

Hi Hampton,

I got this to work:

Place a workbook_SheetChange event in the workbook code sheet.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range)
Dim iNts As Range
Set iNts = Intersect(Sheet1.Range(target.Address), Sheet1.Range("C7:U41"))
If iNts Is Nothing Then Set iNts = Intersect(Sheet2.Range(target.Address), Sheet2.Range("C7:U41"))
If iNts Is Nothing Then Set iNts = Intersect(Sheet3.Range(target.Address), Sheet3.Range("C7:U41"))
If iNts Is Nothing Then Set iNts = Intersect(Sheet4.Range(target.Address), Sheet4.Range("C7:U41"))
If Not iNts Is Nothing Then
Application.ScreenUpdating = False
    Call background_color_count
Application.ScreenUpdating = True

End If
End Sub

Then the sub in a module.

Sub background_color_count()
Dim x As Long, c As Range
x = 0
        For Each c In Sheet1.Range("C7:U41")
            If c.DisplayFormat.Interior.Color <> 16777164 And c.DisplayFormat.Interior.Color <> 16777215 Then x = x + 1
        Next c
        For Each c In Sheet2.Range("C7:U41")
            If c.DisplayFormat.Interior.Color <> 16777164 And c.DisplayFormat.Interior.Color <> 16777215 Then x = x + 1
        Next c
        For Each c In Sheet3.Range("C7:U41")
            If c.DisplayFormat.Interior.Color <> 16777164 And c.DisplayFormat.Interior.Color <> 16777215 Then x = x + 1
        Next c
        For Each c In Sheet4.Range("C7:U41")
            If c.DisplayFormat.Interior.Color <> 16777164 And c.DisplayFormat.Interior.Color <> 16777215 Then x = x + 1
        Next c
Sheet4.Range("AD43").Value2 = x
End Sub

I am sure there must be a more efficient way to check if iNts is empty but I kept getting a global method fail.

Let me know how it goes.

Justin

The function would be a better solution, rather than having to run the macro every time. Either that or writing the code into the sheetchange event so it updates whenever the conditional format is activated. But if the macro does what you need all is good

Hi Roy, Hampton,

I did not test the function but I expect it will not count cells that have been formatted using conditional format, to modify the function to count these cells insert DisplayFormat whenever referencing the colorindex, eg:

change

rCl.Interior.ColorIndex = lCol

to

rCl.DisplayFormat.Interior.ColorIndex = lCol

Without the displayformat the code only counts cells that have had the background color changed using fill-color.

HTH

Justin

Hi,

Try this code in the sheet you posted.

Sub background_color_count()
Dim x As Long, c As Range
x = 0
For Each c In Sheet1.Range("C7:U41")
If c.DisplayFormat.Interior.Color <> 16777164 And c.DisplayFormat.Interior.Color <> 16777215 Then x = x + 1
Next c
For Each c In Sheet2.Range("C7:U41")
If c.DisplayFormat.Interior.Color <> 16777164 And c.DisplayFormat.Interior.Color <> 16777215 Then x = x + 1
Next c
For Each c In Sheet3.Range("C7:U41")
If c.DisplayFormat.Interior.Color <> 16777164 And c.DisplayFormat.Interior.Color <> 16777215 Then x = x + 1
Next c
For Each c In Sheet4.Range("C7:U41")
If c.DisplayFormat.Interior.Color <> 16777164 And c.DisplayFormat.Interior.Color <> 16777215 Then x = x + 1
Next c
Sheet4.Range("AD43").Value2 = x
End Sub

Let me know if it does what you are after.

Justin

Thank you for the like, and for updating your post on the other forum.

Good luck with your projects.

Justin

Try this code in the code for the sheet:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B3:BJ67")) Is Nothing Then
If Range("BR" & Target.Row) > 116 Then
MsgBox "over"
ActiveSheet.Unprotect Password:="PW"
Range("B" & Target.Row & ":BJ" & Target.Row).Locked = True
ActiveSheet.Protect Password:="PW"
End If
End If
End Sub

let me know if it does what you are after.

Hi DJ,

Your scenario would be a lot easier to "imagine" if you provided an example sheet. In what you have written you are suggesting a column full of names, in column A but then you want to hide and show column A. What is happening to the names here? Do you just want a list of names, each name can have any number of lines inserted between one name and the next depending on a selected team size?

Whatever the scenario an example sheet will save a lot of time.

Hi MD,

Your code literally says to stop when you get to a blank cell, just redefine the end point somehow. Eg do until activecell.row = 1000 or wherever your last table row is likely to be.

Hi Mikey,

This will work on the example you have posted, itassumes the same format is always true.

Function GetName3(target As String)
x = InStr(1, target, Chr(10))
If Left(target, 4) = "Dear" Then
GetName3 = Trim(Mid(target, 5, x - 5))
Else
GetName3 = Trim(Mid(target, 1, x - 1))
End If
End Function

HI KD

I think this is what you were trying to do.

Excel Template Macro V10 JDEDIT.xlsm

Let me know how it goes.

I was not sure why you were creating the sheets, then naming them using the array, and then renaming them in the same workbook open event, so I deleted that step... just change the array to name them correctly the first time.

I also moved the array to the sheet so it might be easier to change the sheetnames etc, but you can run it from your original array just fine if you delete the list on the sheet.

There were a few other confusions in there, but I think most of what you are after is there.

Justin