Posts by Justin Doward

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

You need to/could try working through the sheets without selecting them, just perform the operation on the range there is no need to select/activate either the sheet or the range.

something like:

Dim sh As Worksheet
For Each sh In Sheets
sh.Rows("2:18").Group
sh.Rows("20").Group
sh.Outline.ShowLevels rowlevels:=1
Next
End Sub

Then write the code for the activewindows when they are being viewed.

Okay, You need to be a little more succint.

What indicates which row should compare to another, is it the month? i.e. should the code compare each row that reflects January. If this is correct will there only be one row per month or is it by day, fortnight etc.

Need a little clarity.

Did you get the code to work as is? i.e. by attaching the code to the button in the Host.

Hi AM,

I ran the code on the sheets you uploaded, with using the RUN button on the host sheet and assigning this macro to the button and all sheets open. It works fine in this context.

You appear to be running from a form is it?

If the context has changed I need more information to correct the error.

Did you try running the code in the context you uploaded your files?

Hi AM,

Try this method:

Sub comparewbs()
Application.ScreenUpdating = False
Dim wb As Workbook, wb1name As Workbook, wb2name As Workbook
Dim WSArr1, WSArr2
Dim x As Long, y As Long
x = 1
For Each wb In Workbooks
If wb.Name <> "Host.xlsm" Then
If x = 1 Then
WSArr1 = wb.Worksheets(Left(wb.Name, Len(wb.Name) - 5)).UsedRange
Set wb1name = wb
x = x + 1
Else
WSArr2 = wb.Worksheets(Left(wb.Name, Len(wb.Name) - 5)).UsedRange
Set wb2name = wb
End If
End If
Next
On Error Resume Next
For x = LBound(WSArr1, 1) To UBound(WSArr1, 1)
For y = LBound(WSArr1, 2) To UBound(WSArr1, 2)
If WSArr1(x, y) <> WSArr2(x, y) Then
wb1name.Worksheets(Left(wb1name.Name, Len(wb1name.Name) - 5)).Cells(x, y).Interior.Color = 35
wb2name.Worksheets(Left(wb2name.Name, Len(wb2name.Name) - 5)).Cells(x, y).Interior.Color = 35
End If
Next y
Next x
Application.ScreenUpdating = True
End Sub

Hi,

Try this approach, I think it is doing what you are after.

Exit Sub not working JDEDIT.xlsm

Justin

Hi,

You can try this code:

Sub LineCopy()
Application.ScreenUpdating = False
Dim MyCpyArr
Dim SaveName As String
Dim LstRw As Long
Dim src As Workbook: Set src = ActiveWorkbook
Dim ws1 As Worksheet: Set ws1 = Sheets("Paste")
Dim ws2 As Worksheet: Set ws2 = Sheets("template")
Dim wb As Workbook
Dim wsCPY As Worksheet
LstRw = ws1.Cells(Rows.Count, 1).End(xlUp).Row ' finds last row in paste worksheet
Application.DisplayAlerts = False
For i = 2 To LstRw
ws1.Cells(i, 1).Resize(1, 40).Copy ws2.Cells(2, 1).Resize(1, 40)
MyCpyArr = ws2.UsedRange
SaveName = ws1.Range("AO" & i).Text
Set wb = Workbooks.Add()
Set wsCPY = wb.Sheets(1)
wsCPY.Range("A1").Resize(UBound(MyCpyArr, 1), UBound(MyCpyArr, 2)).Value2 = MyCpyArr
wb.SaveAs Filename:="C:\Test\" & SaveName
wb.Close
Next i
ws2.Cells(2, 1).Resize(1, 40).Clear


Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

I have it working in this workbook, you need to create a directory on your C drive called "c:\test" just press the button on the template sheet:

linecopy.xlsb

I do not know how the onedrive directory works, but if this code is doing some of what you want I can have a look working out the directory.

Yudai, there is no macro in the file you uploaded.