VBA moving data to new workbook based on change log

[trev1234]

Hi New to the board so please excuse any errors in this post, I have searched for hours to try and find an answer to this but with no luck.

What I have is a workbook that logs all changes to a sheet, it gives me the sheet name, the cell changed and what the cell was changed too, what I am trying to do is then open a new workbook and using the data in my log select the sheet in the new workbook based on the sheet reference in the log (column a) select the cell again based on the log (column B) and then update that cell with the value in the log (Column C). I need this to loop through all the data and update all data in the log. I hope that makes sense and any help would be appreciated.

thanks
Trev

 

[kanadaaa]

Try this in a standard module:

Function WorksheetExists(SheetName As String) As Boolean
    Dim TempSheetName As String

    TempSheetName = UCase(SheetName)
    WorksheetExists = False
  
    For Each Sheet In Worksheets
        If TempSheetName = UCase(Sheet.Name) Then
            WorksheetExists = True
            Exit Function
        End If
    Next Sheet

End Function

Sub OutputLogsToWorkbook()
    Dim fName As String, desWb As Workbook, i As Long

    With ThisWorkbook.Sheets(1)
    
        fName = Application.InputBox("Name the new workbook", "Name", Type:=2) 'Specify the name for the workbook to create
        If fName = "False" Or fName = "" Then Exit Sub 'If inputbox is cancelled or empty, stop macro
        If Dir(ThisWorkbook.Path & "\" & fName & ".xlsx") <> "" Then 'If the file name is duplicate, show error message
            MsgBox "Failed to create workbook:" & vbCrLf & vbCrLf & "Reason: There is a duplicate workbook", vbExclamation, "Error"
            Exit Sub
        Else 'If the file name is good, create a workbook and output values
            Set desWb = Workbooks.Add
            For i = 1 To .Range("A" & Rows.Count).End(xlUp).Row
                If WorksheetExists(.Cells(i, "A").Value) = False Then
                    desWb.Worksheets.Add After:=desWb.Sheets(Sheets.Count)
                End If
                desWb.Sheets(.Cells(i, "A").Value).Range(.Cells(i, "B").Value).Value = .Cells(i, "C").Value
            Next i
            desWb.SaveAs Filename:=ThisWorkbook.Path & "\" & fName & ".xlsx"
        End If
        
    End With
End Sub

Note:
1. I assume you have file types shown for your files (if not the code doesn't run properly)
2. If the specified file name contains characters that can't be in file names, an error occurs

 

[kanadaaa]

Modified a bug:

Function WorksheetExists(SheetName As String) As Boolean
    Dim TempSheetName As String

    TempSheetName = UCase(SheetName)
    WorksheetExists = False
    
    For Each Sheet In Worksheets
        If TempSheetName = UCase(Sheet.Name) Then
            WorksheetExists = True
            Exit Function
        End If
    Next Sheet

End Function

Sub OutputLogsToWorkbook()
    Dim fName As String, desWb As Workbook, i As Long, sh As Worksheet

    With ThisWorkbook.Sheets(1)
    
        fName = Application.InputBox("Name the new workbook", "Name", Type:=2)
        If fName = "False" Or fName = "" Then Exit Sub
        If Dir(ThisWorkbook.Path & "\" & fName & ".xlsx") <> "" Then
            MsgBox "Failed to create workbook:" & vbCrLf & vbCrLf & "Reason: There is a duplicate workbook", vbExclamation, "Error"
            Exit Sub
        Else
            Set desWb = Workbooks.Add
            For i = 1 To .Range("A" & Rows.Count).End(xlUp).Row
                If WorksheetExists(.Cells(i, "A").Value) = False Then
                    Set sh = desWb.Worksheets.Add(, desWb.Sheets(Sheets.Count))
                    sh.Name = .Cells(i, "A").Value
                End If
                desWb.Sheets(.Cells(i, "A").Value).Range(.Cells(i, "B").Value).Value = .Cells(i, "C").Value
            Next i
            desWb.SaveAs Filename:=ThisWorkbook.Path & "\" & fName & ".xlsx"
        End If
        
    End With
End Sub

 

[trev1234]

Hi Kanadaaa, thank you for your help it is fantastic but could you help me modifying is slightly, I need it to open an existing workbook from my computer and update that and then save the existing workbook and not create a new one.
thanks

 

[trev1234]

Hi Kanadaaa,
I have modified your code as below to suit my needs, I would be grateful if you could have a look and advise if you can see any issues with it, so far it seems to work ok

Function WorksheetExists(SheetName As String) As Boolean
    Dim TempSheetName As String

    TempSheetName = UCase(SheetName)
    WorksheetExists = False
   
    For Each Sheet In Worksheets
        If TempSheetName = UCase(Sheet.Name) Then
            WorksheetExists = True
            Exit Function
        End If
    Next Sheet

End Function

Sub OutputLogsToWorkbook()
    Dim fName As String, desWb As Workbook, i As Long, sh As Worksheet, fname2 As String

    With ThisWorkbook.Sheets(1)
   
        fName = Range("upfile").Value
        fname2 = Range("upfile2").Value
            Set desWb = Workbooks.Open(Filename:=fname2)
            For i = 1 To .Range("A" & Rows.Count).End(xlUp).Row
                If WorksheetExists(.Cells(i, "A").Value) = False Then
                    Set sh = desWb.Worksheets.Add(, desWb.Sheets(Sheets.Count))
                    sh.Name = .Cells(i, "A").Value
                End If
                desWb.Sheets(.Cells(i, "A").Value).Range(.Cells(i, "B").Value).Value = .Cells(i, "C").Value
            Next i
            desWb.Save
       
    End With
End Sub

 

[kanadaaa]

The variable fName isn't used anywhere in the code so it can go (erased fname2 and incorporated it into fName).

Sub OutputLogsToWorkbook()
    Dim fName As String, desWb As Workbook, i As Long, sh As Worksheet

    With ThisWorkbook.Sheets(1)
   
        fName = Range("upfile2").Value
        Set desWb = Workbooks.Open(Filename:=fName)
        For i = 1 To .Range("A" & Rows.Count).End(xlUp).Row
            If WorksheetExists(.Cells(i, "A").Value) = False Then
                Set sh = desWb.Worksheets.Add(, desWb.Sheets(Sheets.Count))
                sh.Name = .Cells(i, "A").Value
            End If
            desWb.Sheets(.Cells(i, "A").Value).Range(.Cells(i, "B").Value).Value = .Cells(i, "C").Value
        Next i
        desWb.Save
       
    End With
End Sub

 

[trev1234]

thank you for all your help Kanadaaa

 

[kanadaaa]

You're welcome
Come back anytime when you get further questions.