One input form that updates two worksheets

[erutherford]

Current using excel 2016 home version.

I am looking for VBA that will update two separate worksheets (customers & cars) using 1 worksheet (input). I am new at this so I started by doing one worksheet. I found the code below and modified it and it works fine, but now I am struggling with two worksheets.

Is it doable?

Sub UpdateLogWorksheet()

    Dim CustomersWks As Worksheet
    Dim inputWks As Worksheet

    Dim nextRow As Long
    Dim oCol As Long

    Dim myRng As Range
    Dim myCopy As String
    Dim myCell As Range
    
    'cells to copy from Input sheet
    myCopy = "C3,C5,C7,C9,C11,G3,G5,G7,G9,G11"

    Set inputWks = Worksheets("Input")
    Set CustomersWks = Worksheets("Customers")

    With CustomersWks
        nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
    End With

    With inputWks
        Set myRng = .Range(myCopy)

        If Application.CountA(myRng) <> myRng.Cells.Count Then
            MsgBox "Please fill in all the cells!"
            Exit Sub
        End If
    End With

    With CustomersWks
        With .Cells(nextRow, "A")
            .Value = Now
            .NumberFormat = "mm/dd/yyyy hh:mm:ss"
        End With
        .Cells(nextRow, "B").Value = Application.UserName
        oCol = 3
        For Each myCell In myRng.Cells
            CustomersWks.Cells(nextRow, oCol).Value = myCell.Value
            oCol = oCol + 1
        Next myCell
    End With
    
    'clear input cells that contain constants
    With inputWks
      On Error Resume Next
         With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
              .ClearContents
              Application.GoTo .Cells(1) ', Scroll:=True
         End With
      On Error GoTo 0
    End With
End Sub

 

[dmt32]

hi,
try this update to your code & see if does what you want

Sub UpdateLogWorksheet()
    
    Dim inputWks As Worksheet, sh As Worksheet
    Dim nextRow As Long
    Dim i As Integer
    Dim myRng As Range, cell As Range
    Dim DataEntry() As Variant
    
    Set inputWks = ThisWorkbook.Worksheets("Input")
    
    
'cells to copy from Input sheet
    Set myRng = inputWks.Range("C3,C5,C7,C9,C11,G3,G5,G7,G9,G11")
    
'size dataentry array
    ReDim DataEntry(1 To myRng.Cells.Count)
    
    i = 0
    For Each cell In myRng.Cells
        i = i + 1
        If Len(cell) = 0 Then
'mark blank cell interior color (yellow)
            cell.Interior.ColorIndex = 6
        Else
'populate array
            DataEntry(i) = cell.Value
'clear cell interior color
            cell.Interior.ColorIndex = xlNone
        End If
        Next cell
        
        If Application.CountA(myRng) <> myRng.Cells.Count Then
'inform user
            MsgBox "Please fill in all the cells!", 48, "Complete All Fields"
            Exit Sub
        Else
            On Error Resume Next
'clear input cells that contain constants
            myRng.SpecialCells(xlCellTypeConstants).ClearContents
            On Error GoTo myerror
        End If
        
'apply data entry to two sheets
        For Each sh In ThisWorkbook.Worksheets(Array("Customers", "Cars"))
            nextRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
            With sh.Cells(nextRow, "A")
                .Value = Now
                .NumberFormat = "mm/dd/yyyy hh:mm:ss"
            End With
            sh.Cells(nextRow, "B").Value = Environ("UserName")
            sh.Cells(nextRow, 3).Resize(, UBound(DataEntry)).Value = DataEntry
        Next
        
myerror:
    If Err <> 0 Then
'report errors
        MsgBox (Error(Err)), 48, "Error"
    Else
'inform user
        MsgBox "Data Entry Complete", 64, "Entry Complete"
    End If
        
End Sub

Dave

 

[erutherford]

Thanks for the reply. The code will copy to both sheets, but the same data. We need C3,C5,C7,C9,C11,G3,G5,G9,G11 to copy to "Customers" sheet.
We need C17,C19,C21,C23,G17,G19,G21,G23,G25 to copy to "Cars" sheet.

Thanks

 

[erutherford]

BTW - really like the error handling function!

 

[dmt32]

Thanks for the reply. The code will copy to both sheets, but the same data. We need C3,C5,C7,C9,C11,G3,G5,G9,G11 to copy to "Customers" sheet.
We need C17,C19,C21,C23,G17,G19,G21,G23,G25 to copy to "Cars" sheet.

Thanks

Hi,
It would have been helpful if you had posted this information at start.
When I have moment, will see if can update my suggestion for you.

Dave

 

[dmt32]

try this update

Sub UpdateLogWorksheet()
    
    Dim inputWks As Worksheet, sh As Worksheet
    Dim nextRow As Long
    Dim i As Integer, a As Integer
    Dim myRng(1 To 2) As Range, cell As Range
    Dim DataEntry() As Variant
    Dim ShowMsg As Boolean
    
    Set inputWks = ThisWorkbook.Worksheets("Input")
    
    
'cells to copy from Input sheet
    Set myRng(1) = inputWks.Range("C3,C5,C7,C9,C11,G3,G5,G7,G9,G11")
    Set myRng(2) = inputWks.Range("C17 , C19, C21, C23, G17, G19, G21, G23, G25")
    
'size dataentry array
    ReDim DataEntry(1 To myRng(1).Cells.Count, 1 To myRng(2).Cells.Count)
    
    i = 0
    For Each cell In Union(myRng(1), myRng(2)).Cells
        i = i + 1
        If Not Intersect(cell, myRng(1)) Is Nothing Then a = 1 Else a = 2
'add data to array
        If Len(cell) = 0 Then
'mark blank cell interior color (yellow)
            cell.Interior.ColorIndex = 6
        Else
'populate array
            DataEntry(i, a) = cell.Value
'clear cell interior color
            cell.Interior.ColorIndex = xlNone
        End If
're-set counter
        If i = myRng(a).Cells.Count Then i = 0
'check all cells in range area complete
        If i = 0 And Application.CountA(myRng(a)) <> myRng(a).Cells.Count Then ShowMsg = True
        Next cell
        
        On Error Resume Next
        
        If ShowMsg Then
'inform user
            MsgBox "Please fill in all the cells!", 48, "Complete All Fields"
            Exit Sub
        Else
'clear input cells that contain constants
            Union(myRng(1), myRng(2)).SpecialCells(xlCellTypeConstants).ClearContents
        End If
        
        On Error GoTo myerror
        
'apply data entry to two sheets
        a = 0
        For Each sh In ThisWorkbook.Worksheets(Array("Customers", "Cars"))
            a = a + 1
            nextRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
            With sh.Cells(nextRow, "A")
                .Value = Now
                .NumberFormat = "mm/dd/yyyy hh:mm:ss"
            End With
            sh.Cells(nextRow, "B").Value = Environ("UserName")
'output array to range
            For i = 1 To UBound(DataEntry, a)
                sh.Cells(nextRow, i + 2).Value = DataEntry(i, a)
                Next i
            Next
            
myerror:
            If Err <> 0 Then
'report errors
                MsgBox (Error(Err)), 48, "Error"
            Else
'inform user
                MsgBox "Data Entry Complete", 64, "Entry Complete"
            End If
End Sub

Dave

 

[erutherford]

Thanks Dave, worked perfect! Crafting questions is as sensitive as writing the code, lesson learned!
Thanks again for your effort!

 

[dmt32]

Thanks Dave, worked perfect! Crafting questions is as sensitive as writing the code, lesson learned!
Thanks again for your effort!

Always best to try & fully explain what it is you want your code to do.

Pleased solution now doing what you want - there is a minor change you can try but not critical

you can try replacing this part

'output array to range
                 For i = 1 To UBound(DataEntry, a)
                sh.Cells(nextRow, i + 2).Value = DataEntry(i, a)
                Next i

with this

'output array to range
            sh.Cells(nextRow, 3).Resize(1, UBound(DataEntry, a)).Value = _
            Application.Transpose(Application.Index(DataEntry, 0, a))

It just replaces the loop - its no big deal & you can leave as published if happy with it.
I was just having bit of brain fade when updating the code & just opted for quickest thing I could think of.


Dave