VBA for daily Trakker

[Mumgirl]

Hi All,



Wish you all, Happy new year, Hope you are doing good !!!

I am new on MrExcel Forum, looking for VBA for few tasks

First Task – One-time activity

I am preparing the workforce daily tracking sheet for all our partners, we will send this file by mail to the partners.

Once they open this file, they will fill details in Starting B1 to B4, there is one filed “Pin to Transfer Data” A5, here they will put their desired pin – will explain this bit letter

Starting B7 to B26 they will write Technician Name, I want to have a macro to create (Add) sheets based on a list provided in B7:B26.

I want to prevent macro in duplicating sheet however user can add technician name to list and macro should be able to create sheet based on newly added name in range B7:B26

Once a sheet is created, I want to copy mater data format from a sheet called hidden – this data should come with formatting and all data validations

In home tab apart from A1:E30 Rest cells should be protected with Password ( Password=1234)

Daily Monitoring Format.xlsb
	A	B	C	D	E
1	Region	North
2	Branch	Calcutta
3	ASC Name	Kaka Electronics
4	GCS Code	G2345562
5	Pin to Transfer Data
6	T#	Name
7	T1
8	T2
9	T3
10	T4
11	T5
12	T6
13	T7
14	T8
15	T9
16	T10
17	T11
18	T12
19	T13
20	T14
21	T15
22	T16
23	T17
24	T18
25	T19
26	T20
27
28
29
Home

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
B6:B26	Cell Value	duplicates	text	NO

Cells with Data Validation
Cell	Allow	Criteria
B1	List	East,North,South,West
B2	List	Ahmedabad,Bangalore,Bhubaneswar,Calcutta,Chandigarh,Chennai,Delhi,Ghaziabad,Guwahati,Hyderabad,Indore,Jaipur,Kochi,Lucknow,Mumbai,Pune

Second Task
Once Technician sheets are created, the user will fill the required details in each technician list on daily basis.

I want to have a macro button on each sheet by clicking this button macro to ask to enter “Pin to Transfer Data” using input box and match input data with cell B5 in Home tab, this is just to prevent accidental transfer of data

If the input value is matching with B5 copy date dynamically ( sheet may have less data – macro to check data Cell B2 to last filled row and copy ) and paste it in “ASC Summary” sheet in column E Date, if not matching show massage, “Please enter correct code”,

Macro to append data on each transfer.

The region, Branch, GCS code, Technician Name data is not available in Technician sheet, macro to take input of Region, Branch, GCS code from Home tab and technician name from sheet name from where data was transferred. Macro to match Row with data copied from sheet to avoid any mismatch.



I don’t know how difficult this activity but am looking forward for support from experts.

Thanks
MumGirl

 

[EFANYoutube]

In any case please share and explain here. Refer to #4 of the Forum Rules, particularly the last two paragraphs.

Awesome Peter, thanks for the reminder

 

[EFANYoutube]

OK, I have made up some code to do your second task.
Please double check all the ranges and make sure they line up

Sub addSheets()

For Each cell In ThisWorkbook.Sheets("Home").Range("B7:B26").Cells
    If cell <> "" Then 'if not at the end of the tech list then
        If DuplicateSheet(cell.Value) = False Then 'if tech name not a duplicate
            ThisWorkbook.Worksheets.Add 'Add a sheet
            ActiveSheet.Name = cell.Value 'Name sheet tech name
            ThisWorkbook.Sheets("Hidden").Cells.Copy ActiveSheet.Cells 'copy template from hiddel sheet to new sheet
            CreateButton ThisWorkbook.Sheets(cell.Value) 'create button on new sheet
        End If
    End If
Next cell

End Sub

Function DuplicateSheet(SheetName As String) As Boolean
    DuplicateSheet = False
    For Each sheet In ThisWorkbook.Sheets 'go through each sheet and make sure name doesn't already exist
        If sheet.Name = SheetName Then
            DuplicateSheet = True 'if duplicate then ignore sheet creation
            Exit For
        End If
    Next sheet
End Function

Function CreateButton(sht As Worksheet)
sht.Buttons.Add(199.5, 20, 81, 36).Name = "New Button" ' Change these values to move and resize the buttons
With sht.Buttons("New Button")
    .Text = "Transfer Data" ' Text on the button
    .OnAction = "Transfer" ' sub called when button pressed
End With
End Function


Sub Transfer()
    'check pin with input
    Answer = InputBox("Please type the transfer pin from the home sheet here to continue", "Transfer the data now?")
    If Answer <> "" Then
        If Answer = ThisWorkbook.Sheets("Home").Range("B5") & "" Then
            'Passed all the tests
            If ThisWorkbook.Sheets("ASC Summary").Range("A2").Offset(1) = "" Then
                LastRow = ThisWorkbook.Sheets("ASC Summary").Range("A2").Offset(1).row
            Else
                LastRow = ThisWorkbook.Sheets("ASC Summary").Range("A2").End(xlDown).row + 1
            End If
            'Transfer data
            With ActiveSheet
                'add sheet data
                .Range("A2", "Q" & .Range("A1").End(xlDown).row).Copy ThisWorkbook.Sheets("ASC Summary").Cells(LastRow, 5)
                'add home data
                With ThisWorkbook.Sheets("Home")
                    .Range("B1:B2").Copy
                    ThisWorkbook.Sheets("ASC Summary").Cells(LastRow, 1).PasteSpecial Transpose:=True
                    ThisWorkbook.Sheets("ASC Summary").Cells(LastRow, 3) = .Range("B4")
                End With
                ThisWorkbook.Sheets("ASC Summary").Cells(LastRow, 4) = .Name
                'Delete Sheet
                Application.DisplayAlerts = False 'turn off message to delete sheet
                .Delete
                Application.DisplayAlerts = True
            End With

        Else
            MsgBox "You have not entered the correct pin" & vbNewLine & "Please try again", vbCritical + vbOKOnly, "Something went wrong"
        End If
    End If
End Sub

 

[Mumgirl]

OK, I have made up some code to do your second task.
Please double check all the ranges and make sure they line up

Sub addSheets()

For Each cell In ThisWorkbook.Sheets("Home").Range("B7:B26").Cells
    If cell <> "" Then 'if not at the end of the tech list then
        If DuplicateSheet(cell.Value) = False Then 'if tech name not a duplicate
            ThisWorkbook.Worksheets.Add 'Add a sheet
            ActiveSheet.Name = cell.Value 'Name sheet tech name
            ThisWorkbook.Sheets("Hidden").Cells.Copy ActiveSheet.Cells 'copy template from hiddel sheet to new sheet
            CreateButton ThisWorkbook.Sheets(cell.Value) 'create button on new sheet
        End If
    End If
Next cell

End Sub

Function DuplicateSheet(SheetName As String) As Boolean
    DuplicateSheet = False
    For Each sheet In ThisWorkbook.Sheets 'go through each sheet and make sure name doesn't already exist
        If sheet.Name = SheetName Then
            DuplicateSheet = True 'if duplicate then ignore sheet creation
            Exit For
        End If
    Next sheet
End Function

Function CreateButton(sht As Worksheet)
sht.Buttons.Add(199.5, 20, 81, 36).Name = "New Button" ' Change these values to move and resize the buttons
With sht.Buttons("New Button")
    .Text = "Transfer Data" ' Text on the button
    .OnAction = "Transfer" ' sub called when button pressed
End With
End Function


Sub Transfer()
    'check pin with input
    Answer = InputBox("Please type the transfer pin from the home sheet here to continue", "Transfer the data now?")
    If Answer <> "" Then
        If Answer = ThisWorkbook.Sheets("Home").Range("B5") & "" Then
            'Passed all the tests
            If ThisWorkbook.Sheets("ASC Summary").Range("A2").Offset(1) = "" Then
                LastRow = ThisWorkbook.Sheets("ASC Summary").Range("A2").Offset(1).row
            Else
                LastRow = ThisWorkbook.Sheets("ASC Summary").Range("A2").End(xlDown).row + 1
            End If
            'Transfer data
            With ActiveSheet
                'add sheet data
                .Range("A2", "Q" & .Range("A1").End(xlDown).row).Copy ThisWorkbook.Sheets("ASC Summary").Cells(LastRow, 5)
                'add home data
                With ThisWorkbook.Sheets("Home")
                    .Range("B1:B2").Copy
                    ThisWorkbook.Sheets("ASC Summary").Cells(LastRow, 1).PasteSpecial Transpose:=True
                    ThisWorkbook.Sheets("ASC Summary").Cells(LastRow, 3) = .Range("B4")
                End With
                ThisWorkbook.Sheets("ASC Summary").Cells(LastRow, 4) = .Name
                'Delete Sheet
                Application.DisplayAlerts = False 'turn off message to delete sheet
                .Delete
                Application.DisplayAlerts = True
            End With

        Else
            MsgBox "You have not entered the correct pin" & vbNewLine & "Please try again", vbCritical + vbOKOnly, "Something went wrong"
        End If
    End If
End Sub

Hi EFANYoutube,


Thanks a lot for all your efforts !!!

The code is working partially fine.

Only a few observations

1> Once run "addSheets" macro - Sheets are getting created however Data transfer button in coming in between the data ( in cell D1) please let me know how we can shift it to cell W2 for all sheets which will get created
2> On clicking transfer data following actions are happening

1. Complete Sheet ( Newly created Technician sheet) is getting deleted – We want to transfer data and clear from technician sheet we don’t want to delete the sheet
2. Data is getting copied from Technician sheet Cell A1 ( which is serial number Column ) – We want to copy from column B ( Date column) That too till the filled cell only.
3. In some cases the first row is blank - nothing is getting pasted there
4. In Sheet ASC summary Region Branch GCS code and technician name is getting filed in one row only whereas we wanted to paste these details in line with data copied from the technician list and pasted ASC summary list.
5. Data transfer button which is created in technician sheet is also moving in ASC summary – we don’t want this button to get copied and pasted in ASC summary
6. In ASC summary data is getting replaced on click of transfer button whereas we want to append ( wanted to paste new data from next line and keep on moving down)

Please guide me to update the code so that I can change the same accordingly

But overall, I must appreciate your efforts and make it happen.

Thanks a lot for all your support!!!

ASC Daily Monitoring Format - Copy.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W
1	Region	Branch	GCS Code	Technician Name	Date	Work order No	W/o Date	Customer Name	Area	Model No	Serial Number	DOP	Warranty Status	Part Code	Part Qty	Appointment Status	Appointment Time	Status of call	Type of call	Amount Collected	Happy Call Status	Happy Call Date	Remarks
2
3	North	Calcutta	G2345562	Santosh	1	07-01-21	60-14442662886	07-01-21	Aniruth Abhinandana Bhattacharyya	Thiruvananthapuram	HL1643/00	HL0999999999999	07-01-21	Stock Set	########	1	Yes	3:30 PM	Solved		₹ 750.00
4	North	Calcutta	G2345562	Bhikaji	1	07-01-21	Test	07-01-21	Aniruth Abhinandana Bhattacharyya	Thiruvananthapuram	HL1643/00	HL0999999999999	07-01-21	Stock Set	########	1	Yes	3:30 PM	Solved		₹ 750.00
5					2	07-01-21	Test	07-01-21		Thiruvananthapuram	HL1643/00	HL0999999999999	07-01-21	EW					Not Attended
6					3
7					4
8					5
9					6
10					7
11					8
12					9
13					10
14					11
15					12
16					13
17					14
ASC Summary

Cells with Data Validation
Cell	Allow	Criteria
N3:N17	List	IW,OW,Stock Set,EW
Q3:Q17	List	Yes,No
S3:S23	List	Solved,Pending,Not Attended
T3:T23	List	PR,NPR,Exchange,Demo
A3:A5	List	East,North,South,West
B3:B5	List	Ahmedabad,Bangalore,Bhubaneswar,Calcutta,Chandigarh,Chennai,Delhi,Ghaziabad,Guwahati,Hyderabad,Indore,Jaipur,Kochi,Lucknow,Mumbai,Pune

Thanks & Regards

 

[EFANYoutube]

OK, no problems
I have changed the below too 1000, its how far right it will go, just tweek it till its good

sht.Buttons.Add(1000, 20, 81, 36).Name = "New Button" ' Change these values to move and resize the buttons

This line with clear the sheet instead of deleting

.Range("A2:Q100").ClearContents

Changed it to copy from B Column (Date)

In you previous picture your headers were in 2nd row, I have fixed so no empty row now

The reason the button was getting coppied was because it was on top of the data being copied, this should be fixed now with moving the button away from the data

Should be appending now

The updated code below. Just overwrite the code already in your module

Sub addSheets()

For Each cell In ThisWorkbook.Sheets("Home").Range("B7:B26").Cells
    If cell <> "" Then 'if not at the end of the tech list then
        If DuplicateSheet(cell.Value) = False Then 'if tech name not a duplicate
            ThisWorkbook.Worksheets.Add 'Add a sheet
            ActiveSheet.Name = cell.Value 'Name sheet tech name
            ThisWorkbook.Sheets("Hidden").Cells.Copy ActiveSheet.Cells 'copy template from hiddel sheet to new sheet
            CreateButton ThisWorkbook.Sheets(cell.Value) 'create button on new sheet
        End If
    End If
Next cell

End Sub

Function DuplicateSheet(SheetName As String) As Boolean
    DuplicateSheet = False
    For Each sheet In ThisWorkbook.Sheets 'go through each sheet and make sure name doesn't already exist
        If sheet.Name = SheetName Then
            DuplicateSheet = True 'if duplicate then ignore sheet creation
            Exit For
        End If
    Next sheet
End Function

Function CreateButton(sht As Worksheet)
sht.Buttons.Add(1000, 20, 81, 36).Name = "New Button" ' Change these values to move and resize the buttons
With sht.Buttons("New Button")
    .Text = "Transfer Data" ' Text on the button
    .OnAction = "Transfer" ' sub called when button pressed
End With
End Function


Sub Transfer()
    'check pin with input
    Answer = InputBox("Please type the transfer pin from the home sheet here to continue", "Transfer the data now?")
    If Answer <> "" Then
        If Answer = ThisWorkbook.Sheets("Home").Range("B5") & "" Then
            'Passed all the tests
            If ThisWorkbook.Sheets("ASC Summary").Range("A1").Offset(1) = "" Then
                lastrow = ThisWorkbook.Sheets("ASC Summary").Range("A1").Offset(1).row
            Else
                lastrow = ThisWorkbook.Sheets("ASC Summary").Range("A1").End(xlDown).row + 1
            End If
            'Transfer data
            With ActiveSheet
                'add sheet data
                Dim RowCount As Integer
                RowCount = .Range("B1", "B" & .Range("B1").End(xlDown).row).Rows.Count - 1
                .Range("B2", "Q" & RowCount + 1).Copy ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 5)
                'add home data
                With ThisWorkbook.Sheets("Home")
                    .Range("B1:B2").Copy
                    ThisWorkbook.Sheets("ASC Summary").Range(Cells(lastrow, 1), Cells(lastrow + RowCount - 1, 1)).PasteSpecial Transpose:=True
                    ThisWorkbook.Sheets("ASC Summary").Range(Cells(lastrow, 3), Cells(lastrow + RowCount - 1, 3)) = .Range("B4")
                End With
                ThisWorkbook.Sheets("ASC Summary").Range(Cells(lastrow, 4), Cells(lastrow + RowCount - 1, 4)) = .Name
                'Clear Sheet
                .Range("A2:Q100").ClearContents
            End With

        Else
            MsgBox "You have not entered the correct pin" & vbNewLine & "Please try again", vbCritical + vbOKOnly, "Something went wrong"
        End If
    End If
End Sub

 

[sanket_sk]

OK, no problems
I have changed the below too 1000, its how far right it will go, just tweek it till its good

sht.Buttons.Add(1000, 20, 81, 36).Name = "New Button" ' Change these values to move and resize the buttons

This line with clear the sheet instead of deleting

.Range("A2:Q100").ClearContents

Changed it to copy from B Column (Date)

In you previous picture your headers were in 2nd row, I have fixed so no empty row now

The reason the button was getting coppied was because it was on top of the data being copied, this should be fixed now with moving the button away from the data

Should be appending now

The updated code below. Just overwrite the code already in your module

Sub addSheets()

For Each cell In ThisWorkbook.Sheets("Home").Range("B7:B26").Cells
    If cell <> "" Then 'if not at the end of the tech list then
        If DuplicateSheet(cell.Value) = False Then 'if tech name not a duplicate
            ThisWorkbook.Worksheets.Add 'Add a sheet
            ActiveSheet.Name = cell.Value 'Name sheet tech name
            ThisWorkbook.Sheets("Hidden").Cells.Copy ActiveSheet.Cells 'copy template from hiddel sheet to new sheet
            CreateButton ThisWorkbook.Sheets(cell.Value) 'create button on new sheet
        End If
    End If
Next cell

End Sub

Function DuplicateSheet(SheetName As String) As Boolean
    DuplicateSheet = False
    For Each sheet In ThisWorkbook.Sheets 'go through each sheet and make sure name doesn't already exist
        If sheet.Name = SheetName Then
            DuplicateSheet = True 'if duplicate then ignore sheet creation
            Exit For
        End If
    Next sheet
End Function

Function CreateButton(sht As Worksheet)
sht.Buttons.Add(1000, 20, 81, 36).Name = "New Button" ' Change these values to move and resize the buttons
With sht.Buttons("New Button")
    .Text = "Transfer Data" ' Text on the button
    .OnAction = "Transfer" ' sub called when button pressed
End With
End Function


Sub Transfer()
    'check pin with input
    Answer = InputBox("Please type the transfer pin from the home sheet here to continue", "Transfer the data now?")
    If Answer <> "" Then
        If Answer = ThisWorkbook.Sheets("Home").Range("B5") & "" Then
            'Passed all the tests
            If ThisWorkbook.Sheets("ASC Summary").Range("A1").Offset(1) = "" Then
                lastrow = ThisWorkbook.Sheets("ASC Summary").Range("A1").Offset(1).row
            Else
                lastrow = ThisWorkbook.Sheets("ASC Summary").Range("A1").End(xlDown).row + 1
            End If
            'Transfer data
            With ActiveSheet
                'add sheet data
                Dim RowCount As Integer
                RowCount = .Range("B1", "B" & .Range("B1").End(xlDown).row).Rows.Count - 1
                .Range("B2", "Q" & RowCount + 1).Copy ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 5)
                'add home data
                With ThisWorkbook.Sheets("Home")
                    .Range("B1:B2").Copy
                    ThisWorkbook.Sheets("ASC Summary").Range(Cells(lastrow, 1), Cells(lastrow + RowCount - 1, 1)).PasteSpecial Transpose:=True
                    ThisWorkbook.Sheets("ASC Summary").Range(Cells(lastrow, 3), Cells(lastrow + RowCount - 1, 3)) = .Range("B4")
                End With
                ThisWorkbook.Sheets("ASC Summary").Range(Cells(lastrow, 4), Cells(lastrow + RowCount - 1, 4)) = .Name
                'Clear Sheet
                .Range("A2:Q100").ClearContents
            End With

        Else
            MsgBox "You have not entered the correct pin" & vbNewLine & "Please try again", vbCritical + vbOKOnly, "Something went wrong"
        End If
    End If
End Sub

Hi EFANYoutube,

I copied new code and overwrite on earlier code,

But new code is giving error sharing snap below, Please guide

 

[EFANYoutube]

What does the error say

 

[sanket_sk]

What does the error say

 

[EFANYoutube]

Pretty sure i found the issue, there were 3 lines of code where i wasn't being explicit enough

Sub addSheets()

For Each cell In ThisWorkbook.Sheets("Home").Range("B7:B26").Cells
    If cell <> "" Then 'if not at the end of the tech list then
        If DuplicateSheet(cell.Value) = False Then 'if tech name not a duplicate
            ThisWorkbook.Worksheets.Add 'Add a sheet
            ActiveSheet.Name = cell.Value 'Name sheet tech name
            ThisWorkbook.Sheets("Hidden").Cells.Copy ActiveSheet.Cells 'copy template from hiddel sheet to new sheet
            CreateButton ThisWorkbook.Sheets(cell.Value) 'create button on new sheet
        End If
    End If
Next cell

End Sub

Function DuplicateSheet(SheetName As String) As Boolean
    DuplicateSheet = False
    For Each sheet In ThisWorkbook.Sheets 'go through each sheet and make sure name doesn't already exist
        If sheet.Name = SheetName Then
            DuplicateSheet = True 'if duplicate then ignore sheet creation
            Exit For
        End If
    Next sheet
End Function

Function CreateButton(sht As Worksheet)
sht.Buttons.Add(1000, 20, 81, 36).Name = "New Button" ' Change these values to move and resize the buttons
With sht.Buttons("New Button")
    .Text = "Transfer Data" ' Text on the button
    .OnAction = "Transfer" ' sub called when button pressed
End With
End Function


Sub Transfer()
    'check pin with input
    Answer = InputBox("Please type the transfer pin from the home sheet here to continue", "Transfer the data now?")
    If Answer <> "" Then
        If Answer = ThisWorkbook.Sheets("Home").Range("B5") & "" Then
            'Passed all the tests
            If ThisWorkbook.Sheets("ASC Summary").Range("A1").Offset(1) = "" Then
                lastrow = ThisWorkbook.Sheets("ASC Summary").Range("A1").Offset(1).row
            Else
                lastrow = ThisWorkbook.Sheets("ASC Summary").Range("A1").End(xlDown).row + 1
            End If
            'Transfer data
            With ActiveSheet
                'add sheet data
                Dim RowCount As Integer
                RowCount = .Range("B1", "B" & .Range("B1").End(xlDown).row).Rows.Count - 1
                .Range("B2", "Q" & RowCount + 1).Copy ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 5)
                'add home data
                With ThisWorkbook.Sheets("Home")
                    .Range("B1:B2").Copy
                    'Application.Wait (Now + TimeValue("00:00:01"))
                    ThisWorkbook.Sheets("ASC Summary").Range(ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 1), ThisWorkbook.Sheets("ASC Summary").Cells(lastrow + RowCount - 1, 1)).PasteSpecial Transpose:=True
                    ThisWorkbook.Sheets("ASC Summary").Range(ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 3), ThisWorkbook.Sheets("ASC Summary").Cells(lastrow + RowCount - 1, 3)) = .Range("B4")
                End With
                ThisWorkbook.Sheets("ASC Summary").Range(ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 4), ThisWorkbook.Sheets("ASC Summary").Cells(lastrow + RowCount - 1, 4)) = .Name
                'Clear Sheet
                .Range("A2:Q100").ClearContents
            End With

        Else
            MsgBox "You have not entered the correct pin" & vbNewLine & "Please try again", vbCritical + vbOKOnly, "Something went wrong"
        End If
    End If
End Sub

 

[sanket_sk]

Pretty sure i found the issue, there were 3 lines of code where i wasn't being explicit enough

Sub addSheets()

For Each cell In ThisWorkbook.Sheets("Home").Range("B7:B26").Cells
    If cell <> "" Then 'if not at the end of the tech list then
        If DuplicateSheet(cell.Value) = False Then 'if tech name not a duplicate
            ThisWorkbook.Worksheets.Add 'Add a sheet
            ActiveSheet.Name = cell.Value 'Name sheet tech name
            ThisWorkbook.Sheets("Hidden").Cells.Copy ActiveSheet.Cells 'copy template from hiddel sheet to new sheet
            CreateButton ThisWorkbook.Sheets(cell.Value) 'create button on new sheet
        End If
    End If
Next cell

End Sub

Function DuplicateSheet(SheetName As String) As Boolean
    DuplicateSheet = False
    For Each sheet In ThisWorkbook.Sheets 'go through each sheet and make sure name doesn't already exist
        If sheet.Name = SheetName Then
            DuplicateSheet = True 'if duplicate then ignore sheet creation
            Exit For
        End If
    Next sheet
End Function

Function CreateButton(sht As Worksheet)
sht.Buttons.Add(1000, 20, 81, 36).Name = "New Button" ' Change these values to move and resize the buttons
With sht.Buttons("New Button")
    .Text = "Transfer Data" ' Text on the button
    .OnAction = "Transfer" ' sub called when button pressed
End With
End Function


Sub Transfer()
    'check pin with input
    Answer = InputBox("Please type the transfer pin from the home sheet here to continue", "Transfer the data now?")
    If Answer <> "" Then
        If Answer = ThisWorkbook.Sheets("Home").Range("B5") & "" Then
            'Passed all the tests
            If ThisWorkbook.Sheets("ASC Summary").Range("A1").Offset(1) = "" Then
                lastrow = ThisWorkbook.Sheets("ASC Summary").Range("A1").Offset(1).row
            Else
                lastrow = ThisWorkbook.Sheets("ASC Summary").Range("A1").End(xlDown).row + 1
            End If
            'Transfer data
            With ActiveSheet
                'add sheet data
                Dim RowCount As Integer
                RowCount = .Range("B1", "B" & .Range("B1").End(xlDown).row).Rows.Count - 1
                .Range("B2", "Q" & RowCount + 1).Copy ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 5)
                'add home data
                With ThisWorkbook.Sheets("Home")
                    .Range("B1:B2").Copy
                    'Application.Wait (Now + TimeValue("00:00:01"))
                    ThisWorkbook.Sheets("ASC Summary").Range(ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 1), ThisWorkbook.Sheets("ASC Summary").Cells(lastrow + RowCount - 1, 1)).PasteSpecial Transpose:=True
                    ThisWorkbook.Sheets("ASC Summary").Range(ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 3), ThisWorkbook.Sheets("ASC Summary").Cells(lastrow + RowCount - 1, 3)) = .Range("B4")
                End With
                ThisWorkbook.Sheets("ASC Summary").Range(ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 4), ThisWorkbook.Sheets("ASC Summary").Cells(lastrow + RowCount - 1, 4)) = .Name
                'Clear Sheet
                .Range("A2:Q100").ClearContents
            End With

        Else
            MsgBox "You have not entered the correct pin" & vbNewLine & "Please try again", vbCritical + vbOKOnly, "Something went wrong"
        End If
    End If
End Sub

Hi EFANYoutube,

Almost everything is fine only one last point, I have moved transfer button by increasing number to 1600 but still it is getting copied while transferring data to ASC summary.

Could you please share trick to avoid coping the same.

Thanks & Regards

 

[EFANYoutube]

This is just the transfer code so make sure you only overwrite the transfer sub
I added this line twice, one to turn it off then to turn it on again after the copy

                Application.CopyObjectsWithCells = False

So just copy the code below

Sub Transfer()
    'check pin with input
    Answer = InputBox("Please type the transfer pin from the home sheet here to continue", "Transfer the data now?")
    If Answer <> "" Then
        If Answer = ThisWorkbook.Sheets("Home").Range("B5") & "" Then
            'Passed all the tests
            If ThisWorkbook.Sheets("ASC Summary").Range("A1").Offset(1) = "" Then
                lastrow = ThisWorkbook.Sheets("ASC Summary").Range("A1").Offset(1).row
            Else
                lastrow = ThisWorkbook.Sheets("ASC Summary").Range("A1").End(xlDown).row + 1
            End If
            'Transfer data
            With ActiveSheet
                'add sheet data
                Dim RowCount As Integer
                RowCount = .Range("B1", "B" & .Range("B1").End(xlDown).row).Rows.Count - 1
                Application.CopyObjectsWithCells = False
                .Range("B2", "Q" & RowCount + 1).Copy ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 5)
                Application.CopyObjectsWithCells = True
                'add home data
                With ThisWorkbook.Sheets("Home")
                    .Range("B1:B2").Copy
                    'Application.Wait (Now + TimeValue("00:00:01"))
                    ThisWorkbook.Sheets("ASC Summary").Range(ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 1), ThisWorkbook.Sheets("ASC Summary").Cells(lastrow + RowCount - 1, 1)).PasteSpecial Transpose:=True
                    ThisWorkbook.Sheets("ASC Summary").Range(ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 3), ThisWorkbook.Sheets("ASC Summary").Cells(lastrow + RowCount - 1, 3)) = .Range("B4")
                End With
                ThisWorkbook.Sheets("ASC Summary").Range(ThisWorkbook.Sheets("ASC Summary").Cells(lastrow, 4), ThisWorkbook.Sheets("ASC Summary").Cells(lastrow + RowCount - 1, 4)) = .Name
                'Clear Sheet
                .Range("A2:Q100").ClearContents
            End With

        Else
            MsgBox "You have not entered the correct pin" & vbNewLine & "Please try again", vbCritical + vbOKOnly, "Something went wrong"
        End If
    End If
End Sub