Can I get some help with vba code please?

D

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,392
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have a spreadsheet that allows input of costings. I then have buttons to copy the to other sheets according on the date. It needs to be copied to a monthly sheet and a sheet that contains every costing. There is quite a few cells that must have data put into them to arrive at a price. The data is in a table but it only has 1 line. Here is a screenshot of the first few cells https://www.screencast.com/t/jyLkZjmj and here is a shot of the last cells https://www.screencast.com/t/MmRwu22Opd

It gets pasted in the sheets below any rows that already are there. The cells I need copied are: A5:F5, K5:M5. It needs to appear in one line. I can get the A5:F5 to copy but I am not sure about the K5:M5.

Here is a link to the spreadsheet.
cleardot.gif

https://www.dropbox.com/s/<wbr>4qqwxk7bumosvr1/Garrett%27s%<wbr>20costing%20tool%20v6.2.xlsm?<wbr>dl=0

I can't code so I have been trying to piece together things. I need to have cells A5:F5 copied, as well as K5:M5 of the home worksheet.

The combined cells need to be copied to a sheet depending on the date and copied to an the All Costings worksheet.

Here is the code I have:

Code: 
Option Explicit

Private Sub cmdAddRow_Click()

'ActiveSheet.Unprotect Password:="npssadmin"

Dim ws As Worksheet
Set ws = ActiveSheet
Dim tbl As ListObject
Set tbl = ws.ListObjects("tblCosting")
'add a row at the end of the table
tbl.ListRows.Add

'ActiveSheet.Protect Password:="npssadmin"
Application.EnableEvents = True
End Sub


Sub cmdCopy()

'Worksheets("home").Unprotect Password:=costings
    'turn screen updating off
    Application.ScreenUpdating = False
    
    'declare variables
    Dim Lastrow As Long                                                     'number of first empty row in column A of Combo
    Dim Combo As String                                                     'Combo worksheet name
     Dim SecondLastrow As Long                                                'number of first empty row in column A of All costings worksheet
    
    'assign values to variables
    Combo = Worksheets("Home").Range("U5")
    Lastrow = Worksheets(Combo).Cells(Rows.Count, "A").End(xlUp).Row + 1    'number of first empty row in column A of Combo
    SecondLastrow = Worksheets("All Costings").Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    'copy values in cells A5 to d5 of Home worksheet
    Worksheets("Home").Range("A5:F5").copy

    'work with cell at intersection of LastRow and column A of Combo sheet
    With Worksheets(Combo).Cells(Lastrow, 1)
        'paste values
        .PasteSpecial Paste:=xlPasteValues
        'format date
        .Columns("A").NumberFormat = "dd/mm/yyyy"
        'left align the date cell in column A
        .HorizontalAlignment = xlLeft
    End With

    'assign number of first empty row in column B of Combo to Lastrow
    Lastrow = Sheets(Combo).Cells(Rows.Count, "A").End(xlUp).Row
    
    'copy value in cell I5 of home worksheet
    Worksheets("Home").Range("K5").copy
    
    'paste value in cell at intersection of Lastrow and column E of Combo
    Worksheets(Combo).Cells(Lastrow, 7).PasteSpecial Paste:=xlPasteValues
    
    'copy value in cell J5 of Home worksheet
   ' Worksheets("Home").Range("j5").copy
    
    'paste value in cell at intersection of Lastrow and column E of Combo
   ' Worksheets(Combo).Cells(Lastrow, 5).PasteSpecial Paste:=xlPasteValues
    
    'format values in column D of Combo
    'With Worksheets(Combo)
        '.Columns("K5").NumberFormat = "$#,##0.00"
        '.Columns("L5").NumberFormat = "$#,##0.00"
        '.Columns("M5").NumberFormat = "$#,##0.00"
    'End With
    
    'format cells to be in ascending date order
    Call SortDates

    'cancel Cut or Copy mode
    Application.CutCopyMode = False

    'turn screen updating on
    Application.ScreenUpdating = True
    
    Worksheets("home").Range("A5").Select
'Worksheets("home").Protect Password:=costings

End Sub
Sub cmdCopy2()
Worksheets("home").Unprotect Password:="costings"
Application.ScreenUpdating = False

Dim Lastrow As Long



    Lastrow = Worksheets("All Costings").Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    Worksheets("Home").Range("A5:F5").copy
    'work with cell at intersection of LastRow and column A of All Costings worksheet
    With Worksheets("All Costings").Cells(Lastrow, 1)
        'paste values
        .PasteSpecial Paste:=xlPasteValues
        'format date
        .Columns("A").NumberFormat = "dd/mm/yyyy"
        'left align the date cell in column A
        .HorizontalAlignment = xlLeft
    End With

    
    'assign number of first empty row in column B of Combo to Lastrow
    Lastrow = Sheets("All costings").Cells(Rows.Count, "A").End(xlUp).Row
    
    'copy value in cell K5 of home worksheet
    Worksheets("Home").Range("K5").copy
    
    'paste value in cell at intersection of Lastrow and column E of Combo
    Worksheets("All costings").Cells(Lastrow, 7).PasteSpecial Paste:=xlPasteValues
    Worksheets("Home").Range("k5").copy
    Worksheets("All costings").Cells(Lastrow, 8).PasteSpecial Paste:=xlPasteValues
    Worksheets("Home").Range("l5").copy
    Worksheets("All costings").Cells(Lastrow, 9).PasteSpecial Paste:=xlPasteValues
    
    
    
    
    
    
    'copy value in cell J5 of Home worksheet
   ' Worksheets("Home").Range("j5").copy
    
    'paste value in cell at intersection of Lastrow and column E of Combo
   ' Worksheets(Combo).Cells(Lastrow, 5).PasteSpecial Paste:=xlPasteValues
    
    'format values in column D of Combo
    Worksheets("all costings").Columns("G:G").NumberFormat = "$#,##0.00"
    
    'format cells to be in ascending date order
    Call SortDates

    'cancel Cut or Copy mode
    Application.CutCopyMode = False

    'turn screen updating on
    Application.ScreenUpdating = True

'Worksheets("home").Protect Password:="costings"

End Sub

Private Sub cmdAddSheet_Click()
Worksheets("home").Unprotect Password:="costings"
    With ThisWorkbook
        .Sheets.Add(after:=.Sheets(.Sheets.Count)).Name = txtName.Value
        .Sheets("Home").Activate
    End With
'Worksheets("home").Protect Password:="costings"
        
End Sub

Private Sub cmdAddSheetGotoNewSheet_Click()
Worksheets("home").Unprotect Password:="costings"
    With ThisWorkbook
        .Sheets.Add(after:=.Sheets(.Sheets.Count)).Name = txtName.Value
    End With
'Worksheets("home").Protect Password:="costings"
End Sub

Private Sub cmdCopyKeepContents_Click()
Worksheets("home").Unprotect Password:="costings"
    Call cmdCopy
    Call cmdSort
    Call cmdCopy2
    Call cmdSort2
'Worksheets("home").Protect Password:="costings"
End Sub

Private Sub cmdCopyLineBlank_Click()

    Call cmdCopy
    Call cmdSort
    Call cmdCopy2
    Call cmdSort2
Worksheets("home").Unprotect Password:="costings"
    Range("A5:J5").Value = ""
'Worksheets("home").Protect Password:="costings"
    
    End Sub



Private Sub cmdCopySheet_Click()
'Worksheets("home").Unprotect Password:="costings"
    Dim CopyMonth As String
        CopyMonth = Range("J13").Value
        
        Worksheets(CopyMonth).Activate
        Worksheets(CopyMonth).Columns("A:E").Select
            Call AddNew
        'Worksheets("home").Activate
        'Workbooks.Add
        'ActiveSheet.PasteSpecial
'Worksheets("home").Protect Password:="costings"
End Sub

Sub AddNew()
    Dim xWs As Worksheet
    Dim Rng As Range
    Set Rng = Application.Selection
    Application.Workbooks.Add
    Set xWs = Application.ActiveSheet
    Rng.copy Destination:=xWs.Range("A1")
End Sub

Private Sub cmdDeleteRow_Click()
'ActiveSheet.Unprotect Password:="npssadmin"
   Dim ans As Long
    With ActiveSheet.ListObjects("tblCosting").DataBodyRange
        ans = .Rows.Count
        If ans = 0 Then Exit Sub
        If ans > 1 Then .Rows(ans).Delete
        If ans = 1 Then .Rows(1).Cells.SpecialCells(xlCellTypeConstants).ClearContents
    End With
    'Selection.ListObject.ListRows(6).Delete
'ActiveSheet.Protect Password:="npssadmin"
Application.EnableEvents = True
End Sub







Private Sub cmdDelRow_Click()
    
'ActiveSheet.Unprotect Password:="npssadmin"
    Rows("10:10").Select
    Selection.Delete Shift:=xlUp
'ActiveSheet.Protect Password:="npssadmin"
    
End Sub

Private Sub cmdDelSelect_Click()

'ActiveSheet.Unprotect Password:="npssadmin"
    Dim Rng As Range
    
    On Error Resume Next
    With Selection.Cells(1)
        Set Rng = Intersect(.EntireRow, ActiveCell.ListObject.DataBodyRange)
        On Error GoTo 0
        If Rng Is Nothing Then
            MsgBox "Please select a cell within a row that you want to delete.", vbCritical
        Else
            Rng.Delete xlShiftUp
        End If
    End With
Application.EnableEvents = True
'ActiveSheet.Protect Password:="npssadmin"

End Sub


Private Sub cmdAddNoteRow_Click()

'ActiveSheet.Unprotect Password:="npssadmin"
    Rows("10:10").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'ActiveSheet.Protect Password:="npssadmin"

End Sub

Private Sub cmdHide_Click()
cmdAddRow.Visible = False
cmdDeleteRow.Visible = False
cmdDelSelect.Visible = False
cmdHide.Visible = False
End Sub


Private Sub cmdEnterActivities_Click()
Worksheets("home").Unprotect Password:="costings"
    Sheets("home").Range("W5") = txtActivities.Value
'Worksheets("home").Protect Password:="costings"

End Sub
Sub DoMonths()
Worksheets("home").Unprotect Password:="costings"
    Dim J As Integer
    Dim K As Integer
    Dim sMo(12) As String

    sMo(1) = "January"
    sMo(2) = "February"
    sMo(3) = "March"
    sMo(4) = "April"
    sMo(5) = "May"
    sMo(6) = "June"
    sMo(7) = "July"
    sMo(8) = "August"
    sMo(9) = "September"
    sMo(10) = "October"
    sMo(11) = "November"
    sMo(12) = "December"

    For J = 1 To 12
        If J <= Sheets.Count Then
            If Left(Sheets(J).Name, 5) = "Sheet" Then
                Sheets(J).Name = sMo(J)
            Else
                Sheets.Add.Move after:=Sheets(Sheets.Count)
                ActiveSheet.Name = sMo(J)
            End If
        Else
            Sheets.Add.Move after:=Sheets(Sheets.Count)
            ActiveSheet.Name = sMo(J)
        End If
    Next J

    For J = 1 To 12
        If Sheets(J).Name <> sMo(J) Then
            For K = J + 1 To Sheets.Count
                If Sheets(K).Name = sMo(J) Then
                    Sheets(K).Move Before:=Sheets(J)
                End If
            Next K
        End If
    Next J

    Sheets(1).Activate
'Worksheets("home").Protect Password:="costings"
End Sub

Private Sub cmdNewTool_Click()
Dim newDoc As String
    Worksheets("home").Unprotect Password:="costings"
    newDoc = "NPSS work allocation sheet " & Year(Now) + 1 & ".xlsm"

    'ActiveWorkbook.Save
    ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & newDoc
    Workbooks.Open Filename:=ThisWorkbook.Path & "\" & newDoc
    Workbooks("NPSS work allocation sheet " & Year(Now) + 1 & ".xlsm").Worksheets("home").Unprotect Password:="costings"
    
    With Workbooks("NPSS work allocation sheet " & Year(Now) + 1 & ".xlsm").Sheets("home")
        .Range("B20") = "July " & Year(Now)
        .Range("B21") = "August " & Year(Now)
        .Range("B22") = "September " & Year(Now)
        .Range("B23") = "October " & Year(Now)
        .Range("B24") = "November " & Year(Now)
        .Range("B25") = "December " & Year(Now)
        .Range("E20") = "January " & Year(Now) + 1
        .Range("E21") = "February " & Year(Now) + 1
        .Range("E22") = "March " & Year(Now) + 1
        .Range("E23") = "April " & Year(Now) + 1
        .Range("E24") = "May " & Year(Now) + 1
        .Range("E25") = "June " & Year(Now) + 1
    End With
    
    With Workbooks(newDoc)
        .Sheets("July " & Range("D17")).Name = "July " & Year(Now)
            With Sheets("July " & Year(Now))
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "July " & Year(Now)
            End With
            
        .Sheets("August " & Range("D17")).Name = "August " & Year(Now)
            With Sheets("August " & Year(Now))
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "August " & Year(Now)
            End With
            
        .Sheets("September " & Range("D17")).Name = "September " & Year(Now)
            With Sheets("September " & Year(Now))
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "September " & Year(Now)
            End With
            
        .Sheets("October " & Range("D17")).Name = "October " & Year(Now)
            With Sheets("October " & Year(Now))
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "October " & Year(Now)
            End With
            
        .Sheets("November " & Range("D17")).Name = "November " & Year(Now)
            With Sheets("November " & Year(Now))
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "November " & Year(Now)
            End With
            
        .Sheets("December " & Range("D17")).Name = "December " & Year(Now)
            With Sheets("December " & Year(Now))
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "December " & Year(Now)
            End With
             
        .Sheets("January " & Range("D17") + 1).Name = "January " & Year(Now) + 1
            With Sheets("January " & Year(Now) + 1)
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "January " & Year(Now) + 1
            End With
               
        .Sheets("February " & Range("D17") + 1).Name = "February " & Year(Now) + 1
            With Sheets("February " & Year(Now) + 1)
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "February " & Year(Now) + 1
            End With
            
        .Sheets("March " & Range("D17") + 1).Name = "March " & Year(Now) + 1
            With Sheets("March " & Year(Now) + 1)
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "March " & Year(Now) + 1
            End With
                    
        .Sheets("April " & Range("D17") + 1).Name = "April " & Year(Now) + 1
            With Sheets("April " & Year(Now) + 1)
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "April " & Year(Now) + 1
            End With
     
        .Sheets("May " & Range("D17") + 1).Name = "May " & Year(Now) + 1
            With Sheets("May " & Year(Now) + 1)
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "May " & Year(Now) + 1
            End With
            
        .Sheets("June " & Range("D17") + 1).Name = "June " & Year(Now) + 1
            With Sheets("June " & Year(Now) + 1)
                .Range("A4:E2000").Clear
                .Range("A1").Value = "501 NPSS " & "June " & Year(Now) + 1
            End With
            
        .Sheets("All Costings").Range("A4:E2000").Clear
                    
    End With
End Sub

Public Sub OpenLast()
Workbooks.Open Application.RecentFiles(1)
' etc
End Sub





Private Sub Worksheet_activate()

Worksheets("home").Unprotect Password:="costings"
   If txtIncrease.Value = True Then
        Worksheets("home").Range("Y5").Value = "1.1"
   Else
        Worksheets("home").Range("Y5").Value = "1"
   End If
'Worksheets("home").Protect Password:="costings"
End Sub


Private Sub txtIncrease_Click()
Worksheets("home").Unprotect Password:="costings"
   If txtIncrease.Value = True Then
        Worksheets("home").Range("y5").Value = "1.1"
   Else
        Worksheets("home").Range("y5").Value = "1"
   End If
'Worksheets("home").Protect Password:="costings"
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheets("home").Unprotect Password:="costings"
Dim ans As String
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        Application.EnableEvents = False
    If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
        If Target.Value < Date Then
            ans = MsgBox("This input is older than today !....Are you sure that is what you want ???", vbYesNo)
        If ans = vbNo Then Target.Value = ""
        End If
    End If


    Application.EnableEvents = True
'Worksheets("home").Protect Password:="costings"
End Sub

Sub Reset_Me()
Application.EnableEvents = True
End Sub

Sub cmdSort()

Worksheets("home").Unprotect Password:="costings"
   'Sorting procedure
'
    Dim Combo As String
        Combo = Worksheets("Home").Range("U5")
    With Worksheets(Combo)
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("A4:A1000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Worksheets(Combo).Sort
        .SetRange Range("A3:D1000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
Application.CutCopyMode = False
'Worksheets("home").Protect Password:="costings"

End Sub
Sub cmdSort2()

   'Second Sorting procedure
Worksheets("home").Unprotect Password:="costings"
    Dim Lastrow As Long
        Lastrow = Worksheets("All Costings").Cells(Rows.Count, "B").End(xlUp).Row + 1
'
    'Range("A3:D1000").Select
    With Worksheets("All Costings")
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("A4:A1000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Worksheets("All Costings").Sort
        .SetRange Range("A3:D1000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    With Worksheets("All Costings").Cells(Lastrow, 1)
        'format date
        .Columns("A").NumberFormat = "dd/mm/yyyy"
        'left align the date cell in column A
        .HorizontalAlignment = xlLeft
    End With


End With
Application.CutCopyMode = False
'Worksheets("home").Protect Password:="costings"

End Sub




Sub workbook_open()

Worksheets("home").Unprotect Password:="costings"

Application.WindowState = xlMaximized

'Sheets("home").Shapes("txtName").TextFrame.Characters.Text = "Type sheet name here."




    With Worksheets("Home")
    '    .Unprotect Password:="services"
            Worksheets("home").Range("T5").Value = "1"
     '   .Protect Password:="services"
    End With

Sheets("Home").txtName.Text = "Type sheet name here."

Worksheets("home").txtActivities.Text = ""

'Worksheets("home").Range("I5").Value = "0"

'Worksheets("home").Protect Password:="costings"

End Sub



Sub SortDates()
'
' sortDates Macro
Worksheets("home").Unprotect Password:="costings"
  'Set up your variables and turn off screen updating.
   Dim iCounter As Integer
   Dim Combo As String
        Combo = Worksheets("Home").Range("U5")
   Application.ScreenUpdating = False
   
  
   'Sort the rows based on the data in column C

'   Sheets(Combo).Sort Key1:=Range("A4"), _
      Order1:=xlAscending, Header:=xlYes
   
   'Clear out the temporary sorting value in column C, and turn screen updating back on.
   'Columns(3).ClearContents
   Application.ScreenUpdating = True
'Worksheets("home").Protect Password:="costings"
End Sub

Private Sub cmdAddSheet_Click()

    With ThisWorkbook
        .Sheets.Add(after:=.Sheets(.Sheets.Count)).Name = txtName.Value
        
    End With

    Worksheets("home").Activate
    
End Sub

Private Sub cmdAddSheetGotoNewSheet_Click()
    With ThisWorkbook
        .Sheets.Add(after:=.Sheets(.Sheets.Count)).Name = txtName.Value
        
    End With
End Sub
Sub sortDate()
'
' sortDate Macro
'

'
    ActiveWorkbook.Worksheets("July 2018").ListObjects("July18").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("July 2018").ListObjects("July18").Sort.SortFields. _
        Add Key:=Range("July18[[#All],[Date of work]]"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("July 2018").ListObjects("July18").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Function CurrentYear() As Long
    CurrentYear = Year(Now)
End Function
Public Function EasterUSNO(YYYY As Long) As Long
    Dim C As Long
    Dim N As Long
    Dim K As Long
    Dim I As Long
    Dim J As Long
    Dim L As Long
    Dim M As Long
    Dim D As Long
    
    C = YYYY \ 100
    N = YYYY - 19 * (YYYY \ 19)
    K = (C - 17) \ 25
    I = C - C \ 4 - (C - K) \ 3 + 19 * N + 15
    I = I - 30 * (I \ 30)
    I = I - (I \ 28) * (1 - (I \ 28) * (29 \ (I + 1)) * ((21 - N) \ 11))
    J = YYYY + YYYY \ 4 + I + 2 - C + C \ 4
    J = J - 7 * (J \ 7)
    L = I - J
    M = 3 + (L + 40) \ 44
    D = L + 28 - 31 * (M \ 4)
    EasterUSNO = DateSerial(YYYY, M, D)
End Function
Sub Check_Date()

Dim Answer As String
Dim MyNote As String

If [@[Date]] < Now() Then
 
    'Place your text here
    MyNote = "You have entered a date that is in the past, do you want to continue?"
 
    'Display MessageBox
    Answer = MsgBox(MyNote, vbQuestion + vbYesNo, "???")
 
    If Answer = vbNo Then
        'Code for No button Press
        MsgBox "You pressed NO!"
    Else
        'Code for Yes button Press
        MsgBox "You pressed Yes!"
    End If
 
End If

End Sub
Sub SelectBlanks()
Selection.SpecialCells(xlCellTypeBlanks).Select
End Sub


Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Application.EnableEvents = False
        If Range("[@[Date]]").Value < Date Then
            MsgBox "This input is older than today !....Are you sure that is what you want ???"
        End If
Application.EnableEvents = True
End Sub
Sub copy()
'
' copy Macro
'

'
    Range("A5:C5").Select
    Selection.copy
    Sheets("July2018").Select
    ActiveSheet.Paste
End Sub
Sub copy2()
'
' copy2 Macro
'

'
    Range("J5").Select
    Selection.copy
    Sheets("July2018").Select
    Range("D8").Select
    ActiveSheet.Paste
End Sub

Sub insert_button()
'
' insert_button Macro
'

'
    ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _
        , DisplayAsIcon:=False, Left:=570.75, Top:=71.25, Width:=32.25, Height _
        :=12.75).Select
    ActiveSheet.Shapes("CommandButton1").ScaleHeight 0.8823529412, msoFalse, _
        msoScaleFromTopLeft
    Rows("4:4").Select
    Selection.Delete Shift:=xlUp
    Rows("4:4").Select
    Selection.Delete Shift:=xlUp
    Rows("4:4").Select
    Selection.Delete Shift:=xlUp
    Range("E4").Select
    ActiveCell.FormulaR1C1 = "l"
    Rows("4:4").Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.Shapes.Range(Array("CommandButton1")).Select
    ActiveSheet.Shapes("CommandButton1").ScaleHeight 1.2, msoFalse, _
        msoScaleFromTopLeft
    ActiveSheet.Shapes("CommandButton1").ScaleHeight 0.8333333333, msoFalse, _
        msoScaleFromBottomRight
    Rows("4:4").Select
    Selection.Delete Shift:=xlUp
End Sub


Sub AddNew()
    Dim xWs As Worksheet
    Dim Rng As Range
    Set Rng = Application.Selection
    Application.Workbooks.Add
    Set xWs = Application.ActiveSheet
    Rng.copy Destination:=xWs.Range("A1")

End Sub


Could someone who can code help me with this please?a
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
Sort by date Sort by votes
Just pushing this message to the top of the list so people see it.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
VBA help - Locking & unlocking on certain times of day
2
Replies
17
Views
468
dmt32
D
M
  • Question Question
Not running code
Replies
0
Views
218
MagicCarpet
M
H
  • Solved
Copy/Move Data from a table to another Sheet to a table
Replies
2
Views
359
himaruasuka
H
M
  • Question Question
Using VBA code in a protected excel sheet
Replies
2
Views
546
MagicCarpet
M
Ottsel
  • Question Question
Create & Secure PDFS with Excel
Replies
3
Views
270
John_w
J

Forum statistics

Threads
1,224,820
Messages
6,181,159
Members
453,021
Latest member
Justyna P

Share this page

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