One input form that updates two worksheets

erutherford

Active Member
Joined
Dec 19, 2016
Messages
402
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?



Code:
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
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,523
Office Version
  1. 2019
Platform
  1. Windows
hi,
try this update to your code & see if does what you want

Code:
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
 
Last edited:

erutherford

Active Member
Joined
Dec 19, 2016
Messages
402
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
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,523
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

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

Well-known Member
Joined
Jul 3, 2012
Messages
6,523
Office Version
  1. 2019
Platform
  1. Windows
try this update

Code:
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

Active Member
Joined
Dec 19, 2016
Messages
402
Thanks Dave, worked perfect! Crafting questions is as sensitive as writing the code, lesson learned!
Thanks again for your effort!
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,523
Office Version
  1. 2019
Platform
  1. Windows
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

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


with this


Code:
'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
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,130,163
Messages
5,640,515
Members
417,149
Latest member
drbro

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top