pineapplesam
06-10-2021, 07:06 AM
Hi guys,
I have a sheet 'matrix' which has a list of names across the row 2.
They each then have a list of values.
I'm trying to make a macro that will create a new sheet for each of the names based on a template and then add the values with the date it was run at the top. Then when run again it should add another column with the date at the top and only show values that have been changed.
So far creating the sheets works fine. Adding the values was working but seems to have broken and now I'm stuck. Sometimes it seems to work correctly, other times there will be values and no dates, sometimes all of the values rather than just those that have changed.
Please can anyone offer any advice?
Sub Macro2()
'
' Macro2 Macro
'
'
Dim nextCol As Long, firstRow As Long, lastRow As Long, lastVal As Long
Dim n As Variant, nm As Variant, nms As Variant
Const m = "Matrix"
Dim d As String
d = Date
Set nms = Sheets(m).Range("E2", Sheets(m).Range("E2").End(xlToRight)) ' Set range as names
For Each nm In nms
If DoesSheetExists(nm.Value) Then
Else
Sheets("Template").Copy After:=Sheets(Sheets.Count) 'Copies the template worksheet
Sheets(Sheets.Count).Name = nm.Value ' renames the new worksheet
End If
Next nm
with Sheets(m)
nms = Application.WorksheetFunction.Transpose(nms)
End With
For Each nm In nms ' loop through names
n = Application.WorksheetFunction.Match(nm, Sheets(m).Range("2:2"), 0) ' find the column this name appears in on the matrix
'enter changes on the individual sheet
With Sheets(nm)
nextCol = .Cells(2, 1) ' get column number for entries
lastRow = .Range("C" & .Rows.Count).End(xlUp).Row 'last row of tasks
For firstRow = 3 To lastRow
lastVal = Cells(firstRow, Columns.Count).End(xlToLeft).Column ' locate last column with an entry
If .Cells(firstRow, lastVal) = Sheets(m).Cells(firstRow, n) Then ' if the last value matches the value in the matrix
Else: .Cells(firstRow, nextCol) = Sheets(m).Cells(firstRow, n) ' add the value ot the next empty column
End If
Next firstRow
If Application.WorksheetFunction.Sum(Columns(nextCol)) = 0 Then
Else
.Cells(2, nextCol) = d
End If
End With
Next nm
End Sub
Function DoesSheetExists(sh As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sh)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function
I have a sheet 'matrix' which has a list of names across the row 2.
They each then have a list of values.
I'm trying to make a macro that will create a new sheet for each of the names based on a template and then add the values with the date it was run at the top. Then when run again it should add another column with the date at the top and only show values that have been changed.
So far creating the sheets works fine. Adding the values was working but seems to have broken and now I'm stuck. Sometimes it seems to work correctly, other times there will be values and no dates, sometimes all of the values rather than just those that have changed.
Please can anyone offer any advice?
Sub Macro2()
'
' Macro2 Macro
'
'
Dim nextCol As Long, firstRow As Long, lastRow As Long, lastVal As Long
Dim n As Variant, nm As Variant, nms As Variant
Const m = "Matrix"
Dim d As String
d = Date
Set nms = Sheets(m).Range("E2", Sheets(m).Range("E2").End(xlToRight)) ' Set range as names
For Each nm In nms
If DoesSheetExists(nm.Value) Then
Else
Sheets("Template").Copy After:=Sheets(Sheets.Count) 'Copies the template worksheet
Sheets(Sheets.Count).Name = nm.Value ' renames the new worksheet
End If
Next nm
with Sheets(m)
nms = Application.WorksheetFunction.Transpose(nms)
End With
For Each nm In nms ' loop through names
n = Application.WorksheetFunction.Match(nm, Sheets(m).Range("2:2"), 0) ' find the column this name appears in on the matrix
'enter changes on the individual sheet
With Sheets(nm)
nextCol = .Cells(2, 1) ' get column number for entries
lastRow = .Range("C" & .Rows.Count).End(xlUp).Row 'last row of tasks
For firstRow = 3 To lastRow
lastVal = Cells(firstRow, Columns.Count).End(xlToLeft).Column ' locate last column with an entry
If .Cells(firstRow, lastVal) = Sheets(m).Cells(firstRow, n) Then ' if the last value matches the value in the matrix
Else: .Cells(firstRow, nextCol) = Sheets(m).Cells(firstRow, n) ' add the value ot the next empty column
End If
Next firstRow
If Application.WorksheetFunction.Sum(Columns(nextCol)) = 0 Then
Else
.Cells(2, nextCol) = d
End If
End With
Next nm
End Sub
Function DoesSheetExists(sh As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sh)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function