Value of Sheet Cell Data to be referenced in code.

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,064
Office Version
  1. 2016
Platform
  1. Windows
HI
Hoping someone can help, I had a similar problem yesterday and was able to get that fix with the support of this forum Mr Excel . I have been trying to apply the same principle used yesterday in this code, that I wrote some time back. However the new updates do not fully work and I am a bit stuck again.

Reason for change in code
I will be creating copies of worksheets and have to keep using this code over and over again about 50+ times. Rather than do that, a command button will add the changed data to Sheet10 Cells D33 + D34 and the code will be called up from a module, it will use the changes in Sheet10 Cells D33, D34 every time it is run (This Data will keep changing on each command button Click)

Each command button will place different data in Sheet10 Cells D33 + D34
VBA Code:
Command Button1_Click ()
    Sheet10.Range("D33").Value = "Sheet1"     ' The text "Sheet1" will be added to Sheet10 D33
   Sheet10.Range("D34").Value = "Staff Data"    ' The text "Staff Data" will be added to Sheet10 D34
    Application.Run "Module2.CopySheet"    ' Code is written once and called as a module and will get data from Sheet 10
End Sub

These are the 5 parts that need Changing. The original code is commented out, FULL code is below
VBA Code:
'######## IF Statement See if Sheet has Data in it ###########    PART 1
'If Sheet1.Range("a2").Value = "" Then ' ******** ORIGINAL CODE ******
 If Sheets(Sheets("Sheet10").Range("D33").Value).Range("A2").Value = "" Then

''' ########## Copy This Sheet ############ PART 2
'.Sheets("Sheet1").UsedRange.Copy ' ******** ORIGINAL CODE ******
 .Sheets(Sheets("Sheet10").Range("D33").Value).UsedRange.Copy 

''' ########## Name of  New Sheet ############ PART 3               
'ActiveWorkbook.Sheets(1).Name = "Staff Data" ' ******** ORIGINAL CODE ******
 ActiveWorkbook.Sheets(1).Name = Sheets("Sheet10").Range("D34").Value 
                 
''' ############ column width ############# PART 4
'Worksheets("Staff Data").Columns("A:Z").ColumnWidth = 25  ' ******** ORIGINAL CODE ******
 Worksheets(Sheets("Sheet10").Range("D34")).Value.Columns("A:Z").ColumnWidth = 25
    
''''' ########### Name of Sheet + DATE + TIME ########## PART 5
'ActiveWorkbook.SaveAs "Staff Data" & Format(Now, " dd_mm_yyyy    HH_mm_ss") & ".xlsx" ' ******** ORIGINAL CODE ******
 ActiveWorkbook.SaveAs Sheets("Sheet10").Range("D34") & Format(Now, " dd_mm_yyyy    HH_mm_ss") & ".xlsx"
What the code is supposed to do
1) Create a copy of the Original Sheet, Format the header on the new sheet (Add Filter, Freezeframe, change font color of heading), Date/time stamp the new sheet, rename the new sheet tab with given name, Fill Blank cells with a hyphen.

If the original code is left in then it works FINE. I have got it to only half working with my changes. When I use my variation, a new workbook is created, however the new worksheet is Not Named, Dated, Timed, Data is not copied into it, nor is the workbook tab renamed to the new name, or freeze frame + filtered applied. The Original Sheet, from which the data was copied, ends up with the freeze frame and tab renamed.

Full code is below, With ORIGINAL CODE IN IT, but commented out
VBA Code:
'##### Export Staff DATA to excel #########

'######## IF Statement See if Sheet has Data in it ###########    PART 1
'If Sheet1.Range("a2").Value = "" Then ' ******** ORIGINAL CODE ******
If Sheets(Sheets("Sheet10").Range("D33").Value).Range("A2").Value = "" Then
ExportError.show
Else
    Application.SheetsInNewWorkbook = 1
        Workbooks.Add
    With ThisWorkbook

''' ########## Copy This Sheet ############ PART 2
'.Sheets("Sheet1").UsedRange.Copy ' ******** ORIGINAL CODE ******
.Sheets(Sheets("Sheet10").Range("D33").Value).UsedRange.Copy 'Copy this sheet

    ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues
 
''' ########## Name of  New Sheet ############ PART 3               
'ActiveWorkbook.Sheets(1).Name = "Staff Data" ' ******** ORIGINAL CODE ******
ActiveWorkbook.Sheets(1).Name = Sheets("Sheet10").Range("D34").Value 
                
 On Error Resume Next      
''' ############ column width ############# PART 4
'Worksheets("Staff Data").Columns("A:Z").ColumnWidth = 25  ' ******** ORIGINAL CODE ******
Worksheets(Sheets("Sheet10").Range("D34")).Value.Columns("A:Z").ColumnWidth = 25
        
        Range("A1:Z1").Font.Name = "Calibri"
            Range("A1:Z1").HorizontalAlignment = xlCenter
                Range("A1:Z1").Font.Color = vbWhite
                    Range("A1:Z1").Interior.ColorIndex = 16 '.Color = vbGreen
                    
'''''Fill all BLANK CELLS with Hyphen
    Dim r As Range, LastRow As Long
        LastRow = Cells(Rows.Count, a).End(xlUp).Row
            For Each r In Range("A1:Z1" & LastRow)
        If r.Text = "" Then r.Value = "-"
    Next r
    
''''' ########### Name of Sheet + DATE + TIME ########## PART 5
'ActiveWorkbook.SaveAs "Staff Data" & Format(Now, " dd_mm_yyyy    HH_mm_ss") & ".xlsx" ' ******** ORIGINAL CODE ******
ActiveWorkbook.SaveAs Sheets("Sheet10").Range("D34") & Format(Now, " dd_mm_yyyy    HH_mm_ss") & ".xlsx"
          
      On Error Resume Next
      
''''''Freeze panel on new sheet
        Dim ws As Worksheet
            For Each ws In Worksheets
                 ws.Activate
                     With Application.ActiveWindow
                .SplitColumn = 0
            .SplitRow = 1
        End With
            Application.ActiveWindow.FreezePanes = True
                If Not ActiveSheet.AutoFilterMode Then
                ActiveSheet.Range("A1").AutoFilter

        End If
         Next ws
    End With
 End If

Thanks
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
The columns were not formatting to 25, I have fixed this

VBA Code:
' Format Header in new workbook
        ActiveWorkbook.Sheets(1).Columns("A:g").ColumnWidth = 25 ' ###### I missed this line of code, NOW ADDED
        ActiveWorkbook.Sheets(1).Range("A1:g1").Font.Name = "Calibri"
        ActiveWorkbook.Sheets(1).Range("A1:g1").HorizontalAlignment = xlCenter
        ActiveWorkbook.Sheets(1).Range("A1:g1").Font.Color = vbWhite
        ActiveWorkbook.Sheets(1).Range("A1:g1").Interior.ColorIndex = 16 'Color Grey
 
Upvote 0
At the moment you have one procedure in Module 1 which doesn't contain any code and three procedures in Sheet2 which don't look identical to me so I presume they are doing slightly different things. This means you need three procedures in Module1. You create a new procedure by going to the end of the code, type Sub then a space then the name of the procedure and hit <Enter>. An End Sub is automatically inserted. Make sure you don't put the keyword Private before the keyword Sub. This is not necessary in a Module procedure and can can have unintended consequences. You can then put any valid vba code you like between the Sub and the End Sub.

Create three procedures in Module1 and then for each of the three procedures in Sheet2 cut and paste (not copy and paste) the code into the new procedures in Module1.

Say for example you create three procedures called CopyPaste1, CopyPaste2 and CopyPaste3. You then cut all the code from CommandButton1_Click (which leaves only the Sub line and the End Sub line) and paste it into CopyPaste1. Then in CommandButton1_click you put CopyPaste1. It will look like this
VBA Code:
CommandButton1_click
CopyPaste1
End Sub

Do the same for the other two buttons cutting and pasting the CommandButton2_click code into CopyPaste2 and the CommandButton3_click code into CopyPaste3.

ComandButton2_click will look like this
VBA Code:
CommandButton2_click
CopyPaste2
End Sub

and CommandButton3_click will look like this
VBA Code:
CommandButton3_click
CopyPaste3
End Sub

You will always have some code in your sheet because the click event of each button has to initially go to some code connected with the sheet they are on, but after that the click event code can reference the code in Module1.
 
Upvote 0
ExcelGzh

Thanks for this, I should have mentioned that the sheet I uploaded is just a test sheet. The actual workbook is at work. In that workbook all sheets that need to be copied will have code in them as part of the sheet change events.

What I sent you is codes that I am working on, these code will go into Modules on the Master sheet which is at work and has staffing details. Currently I am just trying to put together a code that will work. Hence why the TEST workbook I uploaded has 3 code, I only need one of them and the second Button offer the best code so far.

It is this code that I will place into a module in the Master sheet at work, however in the master sheet at work each sheet has code in it as part of the change sheet events. THEREFORE once a copy of a sheet ash been made I need to remove all code in the copy.

Sorry if I did not make it as clear. My fault.

PS this demo sheet does not have any code in any sheets, as part of the sheet change event, there is NO need for it.
 
Upvote 0
Sharid

If you want to create a workbook that has no code in it, you need to make a new workbook using Workbooks.Add and then SaveAs. Then create the sheets within it using Sheets.Add. To find out more about how Workbooks.Add and Sheets.Add work, type the text into a procedure somewhere - anywhere - then highlight it and press function key <F1>. That will take you to a Microsoft help page.

You will then have a new workbook with new sheets and no vba code. Then copy the contents of each sheet from the existing workbook to the required sheet in the new workbook. If you copy the whole sheet the vba code will come with it but if you copy the sheet contents (eg Range("A:Z").Copy) then you will have no vba code in your new workbook. If you are copying a sheet that has buttons on it and you don't want the buttons on the new sheet, specify formulas-only (I forget the syntax) in the Paste line. The downside of this is that none of the formatting will come across so you will have to write code that formats the new sheet, but I think you have done that anyway.
 
Upvote 0
ExcelGzh

My original code does that, test the first command button, however I was having too much trouble with it so wrote the second. I am limited in VBA. This is why in the third button I was about to attempt, to make a hybrid of the codes in button one and button two.

PS. Thanks for your support
 
Upvote 0
I have got the Hybrid code working,

Posted too early have noticed one error. Dam
 
Upvote 0
This is the only line with the problem, If it in the code it works, but I need it to get the data from Sheet1 B1

VBA Code:
.Sheets("Sheet2").UsedRange.Copy 'Copy this sheet

There is NO vba in the new file.

Code So far, Just 1 issue
VBA Code:
Private Sub CommandButton3_Click()

Application.ScreenUpdating = False
If Sheets(Sheets("Sheet1").Range("B1").Value).Range("A2").Value = "" Then
'ExportError.Show
MsgBox "Nothing to report"
Else
''Copy and Paste Sheet
    Application.SheetsInNewWorkbook = 1
        Workbooks.Add
    With ThisWorkbook
        .Sheets("Sheet2").UsedRange.Copy 'Copy this sheet
        ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues
''Copy and Paste Sheet
'   Application.SheetsInNewWorkbook = 1
'        Workbooks.Add
'    With ThisWorkbook
'        .Sheets("Sheet2").UsedRange.Copy 'Copy this sheet
'        ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues
'' Rename Tab On new Sheet
    Dim TabName As Variant
        TabName = ThisWorkbook.Worksheets("Sheet1").Range("B2").Value
    ActiveWorkbook.Sheets(1).Name = TabName
''##################
'' Format Header in new workbook
        ActiveWorkbook.Sheets(1).Columns("A:g").ColumnWidth = 25
        ActiveWorkbook.Sheets(1).Range("A1:g1").Font.Name = "Calibri"
        ActiveWorkbook.Sheets(1).Range("A1:g1").HorizontalAlignment = xlCenter
        ActiveWorkbook.Sheets(1).Range("A1:g1").Font.Color = vbWhite
        ActiveWorkbook.Sheets(1).Range("A1:g1").Interior.ColorIndex = 16 'Color Grey
' Create a Freeze panel on new sheet
   Dim Wks As Worksheet
        For Each Wks In Worksheets
            Wks.Activate
                With Application.ActiveWindow
                .SplitColumn = 0
            .SplitRow = 1
        End With
        Application.ActiveWindow.FreezePanes = True
            If Not ActiveSheet.AutoFilterMode Then
                ActiveSheet.Range("A1").AutoFilter
            End If
        Next Wks
'Fill all BLANK CELLS with Hyphen
    Dim r As Range, LastRow As Long
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
        For Each r In ActiveWorkbook.Sheets(1).Range("A1:g" & LastRow)
        If r.Text = "" Then r.Value = "-"
    Next r
'Rename Sheet
    Dim SheetName As Variant
   '   Application.DisplayAlerts = False
        SheetName = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
'Save Sheet
    ActiveWorkbook.SaveAs Filename:=(SheetName) & Format(Now, " dd_mm_yyyy    HH_mm_ss") & ".xlsx", FileFormat:=51

   Application.ScreenUpdating = True
End With
End If
End Sub

1608770821645.png
 
Upvote 0
Finally Fixed, Also see Stackoverflow

VBA Code:
Private Sub CommandButton3_Click()

Application.ScreenUpdating = False
If Sheets(Sheets("Sheet1").Range("B1").Value).Range("A2").Value = "" Then
'ExportError.Show
MsgBox "Nothing to report"
Else

''Copy and Paste Sheet
        Application.SheetsInNewWorkbook = 1
        Workbooks.Add
        With ThisWorkbook

'' Refer to this workbook and sheet to copy data        
Dim wkb As Excel.Workbook
Dim wksh As Excel.Worksheet
Dim CopySheet As Variant

    Set wkb = Excel.Workbooks("Test Copy Sheet3B.xlsm") ' USE THIS WORKBOOK, NAME MUST MATCH
    Set wksh = wkb.Worksheets("Sheet1") 'USE THIS SHEET' Name Must Match
    CopySheet = wksh.Range("B1")
    .Sheets(CopySheet).UsedRange.Copy
     ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues 'PASTE IN NEW CREATED WORKBOOK SHEET
     
'' Rename Tab On new Sheet
    Dim TabName As Variant
        TabName = ThisWorkbook.Worksheets("Sheet1").Range("B2").Value
    ActiveWorkbook.Sheets(1).Name = TabName
''##################
 '' Format Header in new workbook
        ActiveWorkbook.Sheets(1).Columns("A:g").ColumnWidth = 25
        ActiveWorkbook.Sheets(1).Range("A1:g1").Font.Name = "Calibri"
        ActiveWorkbook.Sheets(1).Range("A1:g1").HorizontalAlignment = xlCenter
        ActiveWorkbook.Sheets(1).Range("A1:g1").Font.Color = vbWhite
        ActiveWorkbook.Sheets(1).Range("A1:g1").Interior.ColorIndex = 16 'Color Grey
' Create a Freeze panel on new sheet
   Dim wks As Worksheet
        For Each wks In Worksheets
            wks.Activate
                With Application.ActiveWindow
                .SplitColumn = 0
            .SplitRow = 1
        End With
        Application.ActiveWindow.FreezePanes = True
            If Not ActiveSheet.AutoFilterMode Then
                ActiveSheet.Range("A1").AutoFilter
            End If
        Next wks
'Fill all BLANK CELLS with Hyphen
    Dim r As Range, LastRow As Long
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
        For Each r In ActiveWorkbook.Sheets(1).Range("A1:g" & LastRow)
        If r.Text = "" Then r.Value = "-"
    Next r
'Rename Sheet
    Dim SheetName As Variant
   '   Application.DisplayAlerts = False
        SheetName = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
 'Save Sheet
    ActiveWorkbook.SaveAs Filename:=(SheetName) & Format(Now, " dd_mm_yyyy    HH_mm_ss") & ".xlsx", FileFormat:=51

   Application.ScreenUpdating = True
End With
End If
End Sub

1608824910589.png
 
Upvote 0
Solution

Forum statistics

Threads
1,213,546
Messages
6,114,255
Members
448,556
Latest member
peterhess2002

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