Any Ideas?

zendog1960

Active Member
Joined
Sep 27, 2003
Messages
459
Office Version
  1. 2019
Platform
  1. Windows
Good Morning Gurus!

The following is the Summary page. What I would like is to automatically popullate the columns A thru F. If a new sheet is added, by whatever means, The code would look at this list on the summary page and add the necessary sheet name to column A and add the references from that new sheet in the appropriate columns.

How would you code that?
Coin Shooter.xls
ABCDEF
2ParkTimeTotal CoinsTotal ValueTotal PCVTotal VPH
3Example Park2.5084$3.56$0.04$1.42
4
5
6
7
8
9
Location Summary


Thanks in advanced for any and all help!
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
Try this
Code:
Sub GenSummary()
Dim WkSheet As Worksheet
Dim Counter As Integer

Counter = 1
For Each WkSheet In Worksheets
    If WkSheet.Name <> "Location Summary" Then
        Sheets("Location Summary").Range("A3")(Counter, 1).Value = WkSheet.Name
        Sheets("Location Summary").Range("B3")(Counter, 1).Formula = "='" & WkSheet.Name & "'!A16"
        Sheets("Location Summary").Range("C3")(Counter, 1).Formula = "='" & WkSheet.Name & "'!A4"
        'Continue like this
        Counter = Counter + 1
    End If
Next WkSheet
End Sub

HTH,
~Gold Fish
 
Upvote 0
Solution Cause Excel to Crash

I get the message as follows:

Run-time error '-2147417848(80010108)/
Method 'Range' of object_'Worksheet' failed

I am not sure what happened here but now when I run the code, it crashes excel and closes it. Very frustrated but I know you guys can help figure out why this happened.

Here is the code so far!


Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Static OldVal
    Dim NewVal As String
        
        If Range("J11").Value <> OldVal Then
            NewVal = Range("J11").Value
            Range("J11").ClearContents
            Dim wSht As Worksheet
            Dim shtName As String
            shtName = NewVal
            For Each wSht In Worksheets
                If wSht.Name = shtName Then
                    MsgBox "Sheet already exists...Make necessary " & _
                    "corrections and try again."
                    Exit Sub
                End If
            Next wSht
            Sheets("Template").Copy After:=Sheets("Coin Count")
            Sheets("Template").Name = shtName
            Sheets(shtName).Move After:=Sheets("Location Summary")
            Sheets(shtName).Range("A1") = shtName
            Sheets(shtName).Visible = True
            Sheets("Template (2)").Name = ("Template")
            Sheets(shtName).Activate
            Sheets("Location Summary").Activate
            OldVal = ("")
        End If
    Call GenSummary
End Sub

Sub GenSummary()
Dim wSht As Worksheet
Dim Counter As Integer

Counter = 1
For Each wSht In Worksheets
    If wSht.Name <> "Location Summary" Then
        Sheets("Location Summary").Range("A3")(Counter, 1).Value = wSht.Name
        Sheets("Location Summary").Range("B3")(Counter, 1).Formula = "='" & wSht.Name & "'!A16"
        Sheets("Location Summary").Range("C3")(Counter, 1).Formula = "='" & wSht.Name & "'!A4"
        'Continue like this
        Counter = Counter + 1
    End If
Next wSht
End Sub

I desperately need Help with this one! :rolleyes:
 
Upvote 0
I was checking in the VBA code and I notice that some of the sheets are showing like sheet15, sheet16 The following is a list of the current sheets as they are shown in the VBA Project window:

Sheet1(Location Summary)
Sheet15(Coin Count)
Sheet17(Example Park)
Sheet40(Template)
ThisWorkbook

Is the fact that there is a gap from Sheet1(Location Summary) and Sheet15(Coin Count) that is causing the problem? and if so, is there a routine that could renumber then to keep them sequential?
 
Upvote 0
Uh, I've never heard of that problem before... worksheets is a collection of all of the worksheets in the workbook nothing more nothing less. Perhaps they are hidden?

You could add an if statement to check if the sheets are visible like change
Code:
If wSht.Name <> "Location Summary" Then
to
Code:
If wSht.Name <> "Location Summary" and wkSht.visible = true Then

One other suggestion is to make sure to use
Code:
Application.EnableEvents = False
in any worksheet change macro so that the macro cannot trigger itself potentially causing an infinite loop. So do this:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Static OldVal
    Dim NewVal As String

Application.EnableEvents = False
'The Rest of your code here
Application.EnableEvents = True
End Sub

I would love to help you with the error. But when you post errors, can you hit Debug, then indicate what line is highlighted? It makes my job easier if I know which line is causing the error instead of having to search for it.
 
Upvote 0
Current Status - having problems

here is the code as it sits right now.

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Static OldVal
    Dim NewVal As String
    Dim iRow As Long
        
        Application.EnableEvents = False
        If Range("J11").Value <> OldVal Then
            NewVal = Range("J11").Value
            Range("J11").ClearContents
            Dim wSht As Worksheet
            Dim shtName As String
            shtName = NewVal
            For Each wSht In Worksheets
                If wSht.Name = shtName Then
                    MsgBox "Sheet already exists...Make necessary " & _
                    "corrections and try again."
                    Exit Sub
                End If
            Next wSht
            Sheets("Template").Copy After:=Sheets("Coin Count")
            Sheets("Template").Name = shtName
            Sheets(shtName).Move After:=Sheets("Location Summary")
            Sheets(shtName).Range("A1") = shtName
            Sheets(shtName).Visible = True
            Sheets("Template (2)").Name = ("Template")
            Sheets("Location Summary").Activate
               With Worksheets("Location Summary")
                    Dim Sh As Object
                    iRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                    .Cells(iRow, "A").Value = shtName
                    .Cells(iRow, "B").Formula = "='" & shtName & "'!A16" '>=== change cell reference
                    .Cells(iRow, "C").Formula = "='" & shtName & "'!A4" '>=== change cell reference
                    .Cells(iRow, "D").Formula = "='" & shtName & "'!A7" '>=== change cell reference
                    .Cells(iRow, "E").Formula = "='" & shtName & "'!A10" '>=== change cell reference
                    .Cells(iRow, "F").Formula = "='" & shtName & "'!A13" '>=== change cell reference
                End With
            OldVal = ("")
        End If
Application.EnableEvents = True
End Sub

I does in fact create the new tabs with no errors. It is running through, or at least I think it is, the Location Summary page update code but nothing is showing up on the summary page. I am not getting any errors and there is no error handling so I am not sure why it doesn't update the Location Summary sheet.

Can someone look at this code and let me know what is going on?

Thanks guys and gals, I know I am a pest...but I am striving to learn more and more with your guys help!
 
Upvote 0
Part of the code that appears not to be functioning

The code in RED Bold seems not to be doing anything. Why is that? Am I missing something here?


Private Sub Worksheet_Change(ByVal Target As Range)
Static OldVal
Dim NewVal As String
Dim iRow As Long

Application.EnableEvents = False
If Range("J11").Value <> OldVal Then
NewVal = Range("J11").Value
Range("J11").ClearContents
Dim wSht As Worksheet
Dim shtName As String
shtName = NewVal
For Each wSht In Worksheets
If wSht.Name = shtName Then
MsgBox "Sheet already exists...Make necessary " & _
"corrections and try again."
Exit Sub
End If
Next wSht
Sheets("Template").Copy After:=Sheets("Coin Count")
Sheets("Template").Name = shtName
Sheets(shtName).Move After:=Sheets("Location Summary")
Sheets(shtName).Range("A1") = shtName
Sheets(shtName).Visible = True
Sheets("Template (2)").Name = ("Template")
Sheets("Location Summary").Activate
With Worksheets("Location Summary")
Dim Sh As Object
iRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(iRow, "A").Value = shtName
.Cells(iRow, "B").Formula = "='" & shtName & "'!A16" '>=== change cell reference
.Cells(iRow, "C").Formula = "='" & shtName & "'!A4" '>=== change cell reference
.Cells(iRow, "D").Formula = "='" & shtName & "'!A7" '>=== change cell reference
.Cells(iRow, "E").Formula = "='" & shtName & "'!A10" '>=== change cell reference
.Cells(iRow, "F").Formula = "='" & shtName & "'!A13" '>=== change cell reference
End With

OldVal = ("")
End If
Application.EnableEvents = True
End Sub
 
Upvote 0
Code:
Dim Sh As Object
does not serve a purpose

try adding a line that reads:

Code:
MsgBox "Just made cell " & .Cells(iRow, "B").Address & " equal to " & "='" & shtName & "'!A16"
To make sure you are changing the cell you think you are.

HTH,
~Gold Fish
 
Upvote 0

Forum statistics

Threads
1,213,487
Messages
6,113,938
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top