Trying to create a log of entries, it works with one row but not all the others

[JD Taylor]

Hi everyone,

To set the scene, I have pieced together a database which stores confidential health information on an expanding group of patients, utilising a lot of resources from a lot of very smart individuals found on forums like this one.

We start with a main sheet which has several columns of client information which is updated manually daily. I have other sheets which utilise mainly dropdown menus and Vlookup (referring back to the main sheet) to compose relevant daily sheets.

I am trying to create a log of past entries, i.e. so that when new information is entered the old information is stored elsewhere. I began the code trying to get it to work with new entries entered in one cell (and then my plan was to expand).

At present, it works with one row, doing the following...

When info is added into a particular cell, a check for a sheet with a particular client's name is made and if it exists, the information is added to that like a log. But if no such sheet exists, one is created according to the client name, utilising a template, and the info added.

This works for one client, and is keeping a log of several different cells on the correct sheet (particular to the client).

So when something is entered in K3, it looks for a sheet named A3 (or creates one).

What I do not seem to be able to do, is make it work for all the clients (nearly 400 and growing). The problem I think is related to using Target.Address (or Target.Column or Application.Intersect) and having the right client name referred to.

For example, the list of names is within A3:A400, and the target column is K3:K400 - but how to make the code know that when K25 is entered it should be checking for a sheet named A25 is at the moment beyond me.


Here's the code (with lots of comments in to help me as I am still very green)
Function bWorksheetExists(WSName As Variant) As Boolean
On Error Resume Next
bWorksheetExists = (ActiveWorkbook.Worksheets(WSName).Name = WSName)
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
'Dim stStr As String
Dim arrArray() As Variant
'Dim StrArray() As String
Dim lastBRow As Long
Dim lastCRow As Long
Dim lastERow As Long
Dim lastFRow As Long
Dim lastHRow As Long
Dim lastIRow As Long

'The following three lines all work, but which one to pick, which one will let me connect the naming or selection of the sheet to column A??
'If Target.Address = "$K$3" Then
'If Target.Column = 11 And (Target.Row >= 3 And Target.Row <= 400) Then
If Not Application.Intersect(Target, Range("K3:K400")) Is Nothing Then

'Perhaps putting the range A3 to A400 in an array, the right cell can be called upon??
'arrArray = Array("A3:A400")

'How to make this string not look at one cell but at the whole range????
'Check that the worksheet does exist, write the code for that,
stStr = Worksheets("ConsumerNames").Range("$A$3")

If Not bWorksheetExists(arrArray) Then

Sheets.Add Type:=("H:\My Documents\User History.xltm")
ActiveSheet.Range("H" & Rows.Count).End(xlUp).Offset(1) = Target.Value
ActiveSheet.Range("I" & Rows.Count).End(xlUp).Offset(1) = Worksheets("ConsumerNames").Range("$B$2")

With ActiveSheet
.Name = Worksheets("ConsumerNames").Range("$A3")
.Move After:=Worksheets(Worksheets.Count)
End With
ActiveSheet.Visible = xlSheetVisible

Else

'The worksheet does already exist, so add to it by moving the contained data down one column (after the
'template headings) and then add the new data into the top column

'Select the sheet named with the boolean
ActiveWorkbook.Worksheets(stStr).Visible = xlSheetVisible
ActiveWorkbook.Worksheets(stStr).Select

'identify the last row of data
lastHRow = Range("H" & Rows.Count).End(xlUp).Row
lastIRow = Range("I" & Rows.Count).End(xlUp).Row

'select the information and copy it
ActiveWorkbook.Worksheets(stStr).Range("H3:H" & lastHRow).Copy ActiveWorkbook.Worksheets(stStr).Range("H4:H" & lastHRow + 1)
ActiveWorkbook.Worksheets(stStr).Range("I3:I" & lastIRow).Copy ActiveWorkbook.Worksheets(stStr).Range("I4:I" & lastIRow + 1)

ActiveWorkbook.Worksheets(stStr).Range("H3") = Target.Value
ActiveWorkbook.Worksheets(stStr).Range("I3") = Worksheets("ConsumerNames").Range("$B$2")

End If
End If

'Now, do it all again for H3, and after that I3... combining this step with the K3 step would be great, but is to worry about later
If Target.Address = "$H$3" Then
'Check that the worksheet does exist, write the code for that,
stStr = Worksheets("ConsumerNames").Range("$A$3")
If Not bWorksheetExists(stStr) Then

Sheets.Add Type:=("H:\My Documents\User History.xltm")
ActiveSheet.Range("B" & Rows.Count).End(xlUp).Offset(1) = Target.Value
ActiveSheet.Range("C" & Rows.Count).End(xlUp).Offset(1) = Worksheets("ConsumerNames").Range("$B$2")

With ActiveSheet
.Name = Worksheets("ConsumerNames").Range("$A$3")
.Move After:=Worksheets(Worksheets.Count)
End With
ActiveSheet.Visible = xlSheetVisible
'Need to add this new sheet to a new array of individual names, maybe one
'for months too and next year years
Else

'The worksheet does already exist, so add to it by moving the contained data down one column (after the
'template headings) and then add the new data into the top column

'Select the sheet named with the boolean
ActiveWorkbook.Worksheets(stStr).Visible = xlSheetVisible
ActiveWorkbook.Worksheets(stStr).Select
'identify the last row of data
lastBRow = Range("B" & Rows.Count).End(xlUp).Row
lastCRow = Range("C" & Rows.Count).End(xlUp).Row

'select the information and copy it
ActiveWorkbook.Worksheets(stStr).Range("B3:B" & lastBRow).Copy ActiveWorkbook.Worksheets(stStr).Range("B4:B" & lastBRow + 1)
ActiveWorkbook.Worksheets(stStr).Range("C3:C" & lastCRow).Copy ActiveWorkbook.Worksheets(stStr).Range("C4:C" & lastCRow + 1)

ActiveWorkbook.Worksheets(stStr).Range("B3") = Target.Value
ActiveWorkbook.Worksheets(stStr).Range("C3") = Worksheets("ConsumerNames").Range("$B$2")

End If
End If

If Target.Address = "$I$3" Then
'Check that the worksheet does exist, write the code for that,
stStr = Worksheets("ConsumerNames").Range("$A$3")
If Not bWorksheetExists(stStr) Then

Sheets.Add Type:=("H:\My Documents\User History.xltm")
ActiveSheet.Range("E" & Rows.Count).End(xlUp).Offset(1) = Target.Value
ActiveSheet.Range("F" & Rows.Count).End(xlUp).Offset(1) = Worksheets("ConsumerNames").Range("$B$2")

With ActiveSheet
.Name = Worksheets("ConsumerNames").Range("$A$3")
.Move After:=Worksheets(Worksheets.Count)
End With
ActiveSheet.Visible = xlSheetVisible
'Need to add this new sheet to a new array of individual names, maybe one
'for months too and next year years
Else

'The worksheet does already exist, so add to it by moving the contained data down one column (after the
'template headings) and then add the new data into the top column

'Select the sheet named with the boolean
ActiveWorkbook.Worksheets(stStr).Visible = xlSheetVisible
ActiveWorkbook.Worksheets(stStr).Select
'identify the last row of data
lastERow = Range("E" & Rows.Count).End(xlUp).Row
lastFRow = Range("F" & Rows.Count).End(xlUp).Row

'select the information and copy it
ActiveWorkbook.Worksheets(stStr).Range("E3:E" & lastERow).Copy ActiveWorkbook.Worksheets(stStr).Range("E4:E" & lastERow + 1)
ActiveWorkbook.Worksheets(stStr).Range("F3:F" & lastFRow).Copy ActiveWorkbook.Worksheets(stStr).Range("F4:F" & lastFRow + 1)

ActiveWorkbook.Worksheets(stStr).Range("E3") = Target.Value
ActiveWorkbook.Worksheets(stStr).Range("F3") = Worksheets("ConsumerNames").Range("$B$2")

End If
End If
End Sub

 

[Fluff]

Sorry, didn't work

 

[Fluff]

but how to make the code know that when K25 is entered it should be checking for a sheet named A25 is at the moment beyond me.

How about something like this?

Dim WrkSht As Worksheet
    On Error Resume Next
    Set WrkSht = Sheets(Target.Offset(0, -10).Value)
    On Error GoTo 0
    If WrkSht Is Nothing Then
        Sheets.Add Type:=("H:\My Documents\User History.xltm")
        ActiveSheet.Name = Target.Offset(0, -10).Value
    End If
    

End Sub

 

[JD Taylor]

Thanks Fluffy,

Trying to incorporate that into it. I have got it working down to three errors, one I've fixed and the other two I'm close to sorting.

I'll post when I get it.

Cheers again.

 

[JD Taylor]

Thanks again Fluff you master you,

Here she is working beautifully...


Private Sub Worksheet_Change(ByVal Target As Range)
Dim sheetName As String
Dim WrkSht As Worksheet
Dim lastHRow As Long
Dim lastIRow As Long

'If Target.Address = "$K$3" Then
If Target.Column = 11 And (Target.Row >= 3 And Target.Row <= 400) Then
'If Not Application.Intersect(Target, Range("K3:K400")) Is Nothing Then
sheetName = Target.Offset(0, -10).Value
On Error Resume Next
Set WrkSht = Sheets(Target.Offset(0, -10).Value)

WrkSht(sheetName).Select

'identify the last row of data
lastHRow = Range("H" & Rows.Count).End(xlUp).Row
lastIRow = Range("I" & Rows.Count).End(xlUp).Row

'select the information and copy it
ActiveWorkbook.Worksheets(sheetName).Range("H3:H" & lastHRow).Copy ActiveWorkbook.Worksheets(sheetName).Range("H4:H" & lastHRow + 1)
ActiveWorkbook.Worksheets(sheetName).Range("I3:I" & lastIRow).Copy ActiveWorkbook.Worksheets(sheetName).Range("I4:I" & lastIRow + 1)

ActiveWorkbook.Worksheets(sheetName).Range("H3") = Target.Value
ActiveWorkbook.Worksheets(sheetName).Range("I3") = Worksheets("ConsumerNames").Range("$B$2")

With WrkSht
.Move After:=Worksheets(Worksheets.Count)
End With
WrkSht.Visible = xlSheetVisible
ActiveWorkbook.Worksheets(sheetName).Select
On Error GoTo 0

If WrkSht Is Nothing Then

Sheets.Add Type:=("H:\My Documents\User History.xltm")
ActiveSheet.Name = sheetName

ActiveWorkbook.Worksheets(sheetName).Range("H" & Rows.Count).End(xlUp).Offset(1) = Target.Value
ActiveWorkbook.Worksheets(sheetName).Range("I" & Rows.Count).End(xlUp).Offset(1) = Worksheets("ConsumerNames").Range("$B$2")

ActiveWorkbook.Worksheets(sheetName).Visible = xlSheetVisible
ActiveWorkbook.Worksheets(sheetName).Select

End If

End If

End Sub


(Now to get the new sheets to be added into an array automatically so all the hidden and visible sheets show up at the right time...)

Thanks again you Champion

 

[Fluff]

Glad to help.