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

 

[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

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

Excellent now we hit the target, Code is working as per our requirement.

This is amazing, Thanks a lot for all your efforts and support, you are a magician – Really I mean it !!! ???