Auto Populate from dashboard to second spreadsheet

[Joeclupis]

I have a workbook with multiple sheets. I would like to learn how to set up my dashboard so that I can enter data on it, then have the data fill in the first open row on the spreadsheet. The spreadsheet has 17 columns of data with 2 blank columns after the 5th and 9th columns of information. We have over 3900 rows filled in now. I have googled for some help, but the code is above my head. I understand how to have a spreadsheet look at another for data, but not how to use one row on a spreadsheet to fill in a row on a different spreadsheet, and knowing that the row on the second spreadsheet will always change to the next empty row.

Joseph Carney

 

[Joeclupis]

What we would like is that when we place entries into columns B & C that the formula in the cell(s) above are copied down to the next row. Is this considered a "dynamic" entry? we will probably never stop making entries so I don't know what the end row will be.

[COLOR=#333333].Range("A2:A15").FillDown[/COLOR]

To me, this code will ONLY copy into A15 and nothing more, or is the .filldown command telling it to continue ad nauseum?

 

[Roderick_E]

Ok, since it was a simple change of the code... here's the next version. This code has these features:
1. Ability to copy the result to another workbook (not just another worksheet) This means you must now set:
receptor1wbpath = ""
receptorsh1 = receptor1wb.Worksheets("Sheet2")
2. Ability to clear previous entry from master sheet. Set clearer = 1
3. Ability to check for a unique id and do not add if duplicate. Set uidcol to the column on the receptor sheet where the unique ID resides.
4. Ability to check if receptor column is a formula and instead of populating, drag down previous row.

Option Compare Text 'ignore text case
Function ValidAddress(strAddress As String) As Boolean
    Dim r As Range
    On Error Resume Next
    Set r = Worksheets(1).Range(strAddress)
    If Not r Is Nothing Then ValidAddress = True
End Function
Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long


    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0


    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function
Sub copymasterdata()
Dim mastersh As Worksheet
Dim receptor1wb As Workbook
Dim receptor1wbpath As String
Dim receptorsh1 As Worksheet
Dim lastrow1 As Long
Dim masterdatacells As String
Dim recept1cols As String
Dim masterunbound As Variant
Dim recept1unbound As Variant
Dim receptstr As String
Dim maststr As String
Dim i As Long
Dim errmsg As String
Dim clearer As Long
Dim uidcol As String
Dim dupes As String
Dim filldwnrng As String


Application.DisplayAlerts = True
Application.ScreenUpdating = True


receptor1wbpath = "C:\Users\redwards\Desktop\Testwbkdb.xlsx" 'full path of receptor1 workbook
Set mastersh = Worksheets("Sheet1") 'set masterworksheet, change "Sheet1" to worksheet's actual name
If IsWorkBookOpen(receptor1wbpath) Then
Application.ScreenUpdating = False
Set receptor1wb = Workbooks(Dir(receptor1wbpath))
Else
Set receptor1wb = Workbooks.Open(receptor1wbpath) 'set receptor workbook, change receptor1wbpath to workbook's full path
End If
Set receptorsh1 = receptor1wb.Worksheets("Sheet2") 'set receptor sheet, change "Sheet2" to worksheet's actual name
masterdatacells = "A3, B3, C3, D3, E3, G3, H3, I3, J3, L3, M3, N3, O3, P3, Q3, R3, S3" 'these are the cells on the master sheet that will be copied
recept1cols = "A, B, C, D, E, G, H, I, J, L, M, N, O, P, Q, R, S" 'these the the columns to copy to on the receptor sheet
clearer = 0 'set to 1 to clear the master sheet entries after each run
uidcol = "" 'set to column letter of uid. Should also be first letter in recept1cols even if not in order.




'check for valid addresses and matching receptor1cols
masterunbound = Split(masterdatacells, ",")
recept1unbound = Split(recept1cols, ",")
If UBound(masterunbound) <> UBound(recept1unbound) Then
MsgBox "The master columns and the receptor1 columns aren't the same count." & vcbr & " Perhaps there is a missing comma", vbCritical, "ALERT"
Exit Sub
End If
For i = LBound(masterunbound) To UBound(masterunbound)
If ValidAddress(Trim(masterunbound(i))) = False Then
If errmsg = "" Then
errmsg = Trim(masterunbound(i))
Else
errmsg = errmsg & vbCr & Trim(masterunbound(i))
End If
End If
Next i
If errmsg <> "" Then
MsgBox "The following master cell addresses are invalid (may require comma):" & vbCr & "-----------------------" & vbCr & errmsg, vbCritical, "ALERT"
Exit Sub
End If




'unfilter receptor sheet if filtered -- make for each receptor sheet next 3 lines, change numbers
If receptorsh1.AutoFilterMode Then
receptorsh1.Cells.AutoFilter
End If


'determine last row of each receptorsheet -- make for each receptor sheet change numbers
lastrow1 = 1
On Error Resume Next
lastrow1 = receptorsh1.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1
Resume Next ' if no data on sheet
masterunbound = Split(masterdatacells, ",")
recept1unbound = Split(recept1cols, ",")
For i = LBound(masterunbound) To UBound(masterunbound)
receptstr = Trim(recept1unbound(i))
maststr = Trim(masterunbound(i))


'do uid check. Set UIDCOL at beginning of code
If Trim(uidcol) <> "" Then
If receptstr = uidcol Then
If IsError(Application.Match(mastersh.Range(maststr), receptorsh1.Range(receptstr & ":" & receptstr), 0)) = False Then
dupes = mastersh.Range(maststr)
GoTo ender:
Exit Sub
End If
End If
End If
If receptorsh1.Cells(lastrow1 - 1, receptstr).HasFormula Then
filldwnrng = receptorsh1.Cells(lastrow1 - 1, receptstr).Address & ":" & receptorsh1.Cells(lastrow1, receptstr).Address
receptorsh1.Range(filldwnrng).FillDown
Else
receptorsh1.Cells(lastrow1, receptstr) = mastersh.Range(maststr)
End If
If clearer = 1 Then
mastersh.Range(maststr) = ""
End If
Next i


ender:
If dupes <> "" Then
dupes = "Duplicate UID not added:" & vbCr & "------------------" & vbCr & dupes
Else
dupes = "Copied"
End If
Application.DisplayAlerts = False
If receptor1wb.ReadOnly Then
receptor1wb.Close SaveChanges:=False
dupes = receptor1wb.Name & " is READ-ONLY. " & vbCr & "Try again in a moment"
Else
receptor1wb.Close SaveChanges:=True
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox dupes, vbInformation, "CONFIRMATION"


End Sub

 

[Roderick_E]

oops, delete this line if you copied above code before I edited: MsgBox filldwnrng
This was only for testing.

 

[Roderick_E]

One more time.... This version allows you to use a different workbook (if you define pathway) than the master workbook. Or if you leave it undefined, will use same workbook as master. You WILL still have to define the receptor SHEET. Set receptorsh1 = receptor1wb.Worksheets("Sheet2")

Option Compare Text 'ignore text case
Function ValidAddress(strAddress As String) As Boolean
    Dim r As Range
    On Error Resume Next
    Set r = Worksheets(1).Range(strAddress)
    If Not r Is Nothing Then ValidAddress = True
End Function
Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long


    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0


    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function
Sub copymasterdata()
Dim mastersh As Worksheet
Dim receptor1wb As Workbook
Dim receptor1wbpath As String
Dim receptorsh1 As Worksheet
Dim lastrow1 As Long
Dim masterdatacells As String
Dim recept1cols As String
Dim masterunbound As Variant
Dim recept1unbound As Variant
Dim receptstr As String
Dim maststr As String
Dim i As Long
Dim errmsg As String
Dim clearer As Long
Dim uidcol As String
Dim dupes As String
Dim filldwnrng As String


Application.DisplayAlerts = True
Application.ScreenUpdating = True


receptor1wbpath = "" 'full path of receptor1 workbook or leave blank to use same as master workbook
If receptor1wbpath = "" Then
receptor1wbpath = ThisWorkbook.FullName
End If
Set mastersh = Worksheets("Sheet1") 'set masterworksheet, change "Sheet1" to worksheet's actual name
If IsWorkBookOpen(receptor1wbpath) Then
Application.ScreenUpdating = False
Set receptor1wb = Workbooks(Dir(receptor1wbpath))
Else
Set receptor1wb = Workbooks.Open(receptor1wbpath) 'set receptor workbook, change receptor1wbpath to workbook's full path
End If
Set receptorsh1 = receptor1wb.Worksheets("Sheet2") 'set receptor sheet, change "Sheet2" to worksheet's actual name
masterdatacells = "A3, B3, C3, D3, E3, G3, H3, I3, J3, L3, M3, N3, O3, P3, Q3, R3, S3" 'these are the cells on the master sheet that will be copied
recept1cols = "A, B, C, D, E, G, H, I, J, L, M, N, O, P, Q, R, S" 'these the the columns to copy to on the receptor sheet
clearer = 0 'set to 1 to clear the master sheet entries after each run
uidcol = "" 'set to column letter of uid. Should also be first letter in recept1cols even if not in order.




'check for valid addresses and matching receptor1cols
masterunbound = Split(masterdatacells, ",")
recept1unbound = Split(recept1cols, ",")
If UBound(masterunbound) <> UBound(recept1unbound) Then
MsgBox "The master columns and the receptor1 columns aren't the same count." & vcbr & " Perhaps there is a missing comma", vbCritical, "ALERT"
Exit Sub
End If
For i = LBound(masterunbound) To UBound(masterunbound)
If ValidAddress(Trim(masterunbound(i))) = False Then
If errmsg = "" Then
errmsg = Trim(masterunbound(i))
Else
errmsg = errmsg & vbCr & Trim(masterunbound(i))
End If
End If
Next i
If errmsg <> "" Then
MsgBox "The following master cell addresses are invalid (may require comma):" & vbCr & "-----------------------" & vbCr & errmsg, vbCritical, "ALERT"
Exit Sub
End If




'unfilter receptor sheet if filtered -- make for each receptor sheet next 3 lines, change numbers
If receptorsh1.AutoFilterMode Then
receptorsh1.Cells.AutoFilter
End If


'determine last row of each receptorsheet -- make for each receptor sheet change numbers
lastrow1 = 1
On Error Resume Next
lastrow1 = receptorsh1.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1
Resume Next ' if no data on sheet
masterunbound = Split(masterdatacells, ",")
recept1unbound = Split(recept1cols, ",")
For i = LBound(masterunbound) To UBound(masterunbound)
receptstr = Trim(recept1unbound(i))
maststr = Trim(masterunbound(i))


'do uid check. Set UIDCOL at beginning of code
If Trim(uidcol) <> "" Then
If receptstr = uidcol Then
If IsError(Application.Match(mastersh.Range(maststr), receptorsh1.Range(receptstr & ":" & receptstr), 0)) = False Then
dupes = mastersh.Range(maststr)
GoTo ender:
Exit Sub
End If
End If
End If
If receptorsh1.Cells(lastrow1 - 1, receptstr).HasFormula Then
filldwnrng = receptorsh1.Cells(lastrow1 - 1, receptstr).Address & ":" & receptorsh1.Cells(lastrow1, receptstr).Address
receptorsh1.Range(filldwnrng).FillDown
Else
receptorsh1.Cells(lastrow1, receptstr) = mastersh.Range(maststr)
End If
If clearer = 1 Then
mastersh.Range(maststr) = ""
End If
Next i


ender:
If dupes <> "" Then
dupes = "Duplicate UID not added:" & vbCr & "------------------" & vbCr & dupes
Else
dupes = "Copied"
End If
If receptor1wb.Name <> ThisWorkbook.Name Then 'in case using same workbook as master
Application.DisplayAlerts = False
If receptor1wb.ReadOnly Then
receptor1wb.Close SaveChanges:=False
dupes = receptor1wb.Name & " is READ-ONLY. " & vbCr & "Try again in a moment"
Else
receptor1wb.Close SaveChanges:=True
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
MsgBox dupes, vbInformation, "CONFIRMATION"


End Sub

 

[Joeclupis]

I think that I did something wrong. I change the code to match the cells that I am using on the Dashboard page to fill on the Daily Prices page. The formula in columns D and E are not filling down. I do not have the entries in the code for D and E as they are determined by the formula [=SUM(B3800-B3799)] & [=SUM(C3800-C3799)] respectively. Also, we do not have a UID per se, the columns are: DATE, AV GAS, JET A, 100LL, JET-A, 100LL QTY, [BLANK COLUMN], 100LL SALES PRICE, JETA QTY, JETA SALES PRICE.

Another wierd thing is that when I click the enter key, the workbook closes, or Excel crashes. the numbers are entered.

Here is the code that I have;

Option Compare Text 'ignore text caseFunction ValidAddress(strAddress As String) As Boolean
    Dim r As Range
    On Error Resume Next
    Set r = Worksheets(1).Range(strAddress)
    If Not r Is Nothing Then ValidAddress = True
End Function
Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long




    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0




    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function
Sub copymasterdata()
Dim mastersh As Worksheet
Dim receptor1wb As Workbook
Dim receptor1wbpath As String
Dim receptorsh1 As Worksheet
Dim lastrow1 As Long
Dim masterdatacells As String
Dim recept1cols As String
Dim masterunbound As Variant
Dim recept1unbound As Variant
Dim receptstr As String
Dim maststr As String
Dim i As Long
Dim errmsg As String
Dim clearer As Long
Dim uidcol As String
Dim dupes As String
Dim filldwnrng As String




Application.DisplayAlerts = True
Application.ScreenUpdating = True




receptor1wbpath = "H:\Main Airport folder\Airport Files\Fuel\Fuel Trends.xls" 'full path of receptor1 workbook
Set mastersh = Worksheets("Dashboard") 'set masterworksheet, change "Sheet1" to worksheet's actual name
If IsWorkBookOpen("H:\Main Airport folder\Airport Files\Fuel\Fuel Trends.xls") Then
Application.ScreenUpdating = False
Set receptor1wb = Workbooks(Dir("H:\Main Airport folder\Airport Files\Fuel\Fuel Trends.xls"))
Else
Set receptor1wb = Workbooks.Open("H:\Main Airport folder\Airport Files\Fuel\Fuel Trends.xls") 'set receptor workbook, change receptor1wbpath to workbook's full path
End If
Set receptorsh1 = receptor1wb.Worksheets("Daily Prices") 'set receptor sheet, change "Sheet2" to worksheet's actual name
masterdatacells = "D3, E3, F3, D7, E7, F7, G7" 'these are the cells on the master sheet that will be copied
recept1cols = "A, B, C, G, H, I, J" 'these the the columns to copy to on the receptor sheet
clearer = 1 'set to 1 to clear the master sheet entries after each run
uidcol = "A" 'set to column letter of uid. Should also be first letter in recept1cols even if not in order.








'check for valid addresses and matching receptor1cols
masterunbound = Split(masterdatacells, ",")
recept1unbound = Split(recept1cols, ",")
If UBound(masterunbound) <> UBound(recept1unbound) Then
MsgBox "The master columns and the receptor1 columns aren't the same count." & vcbr & " Perhaps there is a missing comma", vbCritical, "ALERT"
Exit Sub
End If
For i = LBound(masterunbound) To UBound(masterunbound)
If ValidAddress(Trim(masterunbound(i))) = False Then
If errmsg = "" Then
errmsg = Trim(masterunbound(i))
Else
errmsg = errmsg & vbCr & Trim(masterunbound(i))
End If
End If
Next i
If errmsg <> "" Then
MsgBox "The following master cell addresses are invalid (may require comma):" & vbCr & "-----------------------" & vbCr & errmsg, vbCritical, "ALERT"
Exit Sub
End If








'unfilter receptor sheet if filtered -- make for each receptor sheet next 3 lines, change numbers
If receptorsh1.AutoFilterMode Then
receptorsh1.Cells.AutoFilter
End If




'determine last row of each receptorsheet -- make for each receptor sheet change numbers
lastrow1 = 1
On Error Resume Next
lastrow1 = receptorsh1.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1
Resume Next ' if no data on sheet
masterunbound = Split(masterdatacells, ",")
recept1unbound = Split(recept1cols, ",")
For i = LBound(masterunbound) To UBound(masterunbound)
receptstr = Trim(recept1unbound(i))
maststr = Trim(masterunbound(i))




'do uid check. Set UIDCOL at beginning of code
If Trim(uidcol) <> "" Then
If receptstr = uidcol Then
If IsError(Application.Match(mastersh.Range(maststr), receptorsh1.Range(receptstr & ":" & receptstr), 0)) = False Then
dupes = mastersh.Range(maststr)
GoTo ender:
Exit Sub
End If
End If
End If
If receptorsh1.Cells(lastrow1 - 1, receptstr).HasFormula Then
filldwnrng = receptorsh1.Cells(lastrow1 - 1, receptstr).Address & ":" & receptorsh1.Cells(lastrow1, receptstr).Address
receptorsh1.Range(filldwnrng).FillDown
Else
receptorsh1.Cells(lastrow1, receptstr) = mastersh.Range(maststr)
End If
If clearer = 1 Then
mastersh.Range(maststr) = ""
End If
Next i




ender:
If dupes <> "" Then
dupes = "Duplicate UID not added:" & vbCr & "------------------" & vbCr & dupes
Else
dupes = "Copied"
End If
Application.DisplayAlerts = False
If receptor1wb.ReadOnly Then
receptor1wb.Close SaveChanges:=False
dupes = receptor1wb.Name & " is READ-ONLY. " & vbCr & "Try again in a moment"
Else
receptor1wb.Close SaveChanges:=True
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox dupes, vbInformation, "CONFIRMATION"

 

[Roderick_E]

Sorry because this project is developing into something larger, I keep fixing/making it better. USE THIS CODE INSTEAD:

Option Compare Text 'ignore text case
Function ValidAddress(strAddress As String) As Boolean
    Dim r As Range
    On Error Resume Next
    Set r = Worksheets(1).Range(strAddress)
    If Not r Is Nothing Then ValidAddress = True
End Function
Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long


    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0


    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function
Sub copymasterdata()
Dim mastersh As Worksheet
Dim mastershstr As String
Dim receptor1wb As Workbook
Dim receptor1wbpath As String
Dim receptorsh1 As Worksheet
Dim receptorsh1str As String
Dim lastrow1 As Long
Dim masterdatacells As String
Dim recept1cols As String
Dim masterunbound As Variant
Dim recept1unbound As Variant
Dim receptstr As String
Dim maststr As String
Dim i As Long
Dim errmsg As String
Dim clearer As Long
Dim uidcol As String
Dim dupes As String
Dim filldwnrng As String


Application.DisplayAlerts = True
Application.ScreenUpdating = True


'****SETTINGS/CONFIGURATIONS*****
mastershstr = "sheet1" 'actual sheet name of the master sheet within this workbook
receptor1wbpath = "" 'full path of receptor1 workbook or leave blank to use same as master workbook
receptorsh1str = "sheet2" 'actual sheet name of the receptor sheet
masterdatacells = "A3, B3, C3, D3, E3, G3, H3, I3, J3, L3, M3, N3, O3, P3, Q3, R3, S3" 'these are the cells on the master sheet that will be copied
recept1cols = "A, B, C, D, E, G, H, I, J, L, M, N, O, P, Q, R, S" 'these the the columns to copy to on the receptor sheet
clearer = 0 'set to 1 to clear the master sheet entries after each run
uidcol = "" 'set to column letter of uid. Should also be first letter in recept1cols even if not in order.
'***********************


'error trapping
If Trim(mastershstr) = "" Then
errmsg = "Press alt+F11 and set mastershstr to the actual name of the master sheet"
End If
If Trim(receptorsh1str) = "" Then
errmsg = "Press alt+F11 and set receptorsh1str to the actual name of the receptor sheet"
End If
If receptor1wbpath = "" Then
receptor1wbpath = ThisWorkbook.FullName
End If
If Dir(receptor1wbpath) = Empty Then
errmsg = "Press alt+F11 and set receptor1wbpath to the full pathway name of the receptor workbook, including the extension such as .xls or .xlxs"
End If
If errmsg <> "" Then
MsgBox errmsg, vbCritical, "ERROR"
Exit Sub
End If




'set worbooks and sheets, open receptor workbook if needed
Set mastersh = Worksheets(mastershstr)
If IsWorkBookOpen(receptor1wbpath) Then
Application.ScreenUpdating = False
Set receptor1wb = Workbooks(Dir(receptor1wbpath))
Else
Set receptor1wb = Workbooks.Open(receptor1wbpath)
End If
Set receptorsh1 = receptor1wb.Worksheets(receptorsh1str)






'check for valid addresses and matching receptor1cols
masterunbound = Split(masterdatacells, ",")
recept1unbound = Split(recept1cols, ",")
If UBound(masterunbound) <> UBound(recept1unbound) Then
MsgBox "The master columns and the receptor1 columns aren't the same count." & vcbr & " Perhaps there is a missing comma", vbCritical, "ALERT"
Exit Sub
End If
For i = LBound(masterunbound) To UBound(masterunbound)
If ValidAddress(Trim(masterunbound(i))) = False Then
If errmsg = "" Then
errmsg = Trim(masterunbound(i))
Else
errmsg = errmsg & vbCr & Trim(masterunbound(i))
End If
End If
Next i
If errmsg <> "" Then
MsgBox "The following master cell addresses are invalid (may require comma):" & vbCr & "-----------------------" & vbCr & errmsg, vbCritical, "ALERT"
Exit Sub
End If




'unfilter receptor sheet if filtered -- make for each receptor sheet next 3 lines, change numbers
If receptorsh1.AutoFilterMode Then
receptorsh1.Cells.AutoFilter
End If


'determine last row of each receptorsheet -- make for each receptor sheet change numbers
lastrow1 = 1
On Error Resume Next
lastrow1 = receptorsh1.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1
Resume Next ' if no data on sheet
masterunbound = Split(masterdatacells, ",")
recept1unbound = Split(recept1cols, ",")
For i = LBound(masterunbound) To UBound(masterunbound)
receptstr = Trim(recept1unbound(i))
maststr = Trim(masterunbound(i))


'do uid check. Set UIDCOL at beginning of code
If Trim(uidcol) <> "" Then
If receptstr = uidcol Then
If IsError(Application.Match(mastersh.Range(maststr), receptorsh1.Range(receptstr & ":" & receptstr), 0)) = False Then
dupes = mastersh.Range(maststr)
GoTo ender:
Exit Sub
End If
End If
End If
If receptorsh1.Cells(lastrow1 - 1, receptstr).HasFormula Then
filldwnrng = receptorsh1.Cells(lastrow1 - 1, receptstr).Address & ":" & receptorsh1.Cells(lastrow1, receptstr).Address
receptorsh1.Range(filldwnrng).FillDown
Else
receptorsh1.Cells(lastrow1, receptstr) = mastersh.Range(maststr)
End If
If clearer = 1 Then
mastersh.Range(maststr) = ""
End If
Next i


ender:
If dupes <> "" Then
dupes = "Duplicate UID not added:" & vbCr & "------------------" & vbCr & dupes
Else
dupes = "Copied"
End If
If receptor1wb.Name <> ThisWorkbook.Name Then 'in case using same workbook as master
Application.DisplayAlerts = False
If receptor1wb.ReadOnly Then
receptor1wb.Close SaveChanges:=False
dupes = receptor1wb.Name & " is READ-ONLY. " & vbCr & "Try again in a moment"
Else
receptor1wb.Close SaveChanges:=True
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
MsgBox dupes, vbInformation, "CONFIRMATION"


End Sub

If you have a receptor column with a formula you will still need to define it in the lists....
masterdatacells = "A3, B3, C3, D3, E3, G3, H3, I3, J3, L3, M3, N3, O3, P3, Q3, R3, S3" 'these are the cells on the master sheet that will be copied
recept1cols = "A, B, C, D, E, G, H, I, J, L, M, N, O, P, Q, R, S" 'these the the columns to copy to on the receptor sheet

So for example, let's say the receptor column C has a formula. You still need to include it like above. And it will still need a corresponding masterdatacells even though it will NOT copy the data from there. So for example, we still need to have C3 even if the user doesn't input anything.

 

[Joeclupis]

Who would have thought that a simple request would end up being 5 pages of code! My boss was shocked at what it ended up being. Thank you very much. Everything is working just fine.

 

[Roderick_E]

You're welcome I'm making a few more improvements, but would require unique records.
1) Editing ability
2) Search ability
3) Automatic unique record number

 

[Joeclupis]

Well,

as for editing -- what exactly are you needing? We will be working in the receptor sheet from time to time. There is a need for us to input information into other columns, but that is only when we order/receipt fresh fuel. as for the master sheet -- the only editing would be the input cells.

as for search -- we don't use the workbook/worksheets to search, this is used to generate multiple charts to visually pass the information along to others.

Automatic UID -- we track by date, and since we are entering it in anyway, there isn't really a need for it.

One thing I was looking at was on the master sheet setting a specific tab order, but after looking as some of the responses on Mr. Excel and Osgrid... Nah we can do without!!! It would be a convenience thing, not a necessity thing.

 

[Roderick_E]

Ok so this version now has these new abilities:
1. Automatic unique ID number (sequential; 1, 2, 3 and so on)
2. Display an existing record (requires unique ID, either user defined or automatic)
3. Edit an existing record (requires unique ID, either user defined or automatic)

Here is the new code. Special thanks to Joeclupis for all the input!

Option Compare Text 'ignore text case
Function ValidAddress(strAddress As String) As Boolean
    Dim r As Range
    On Error Resume Next
    Set r = Worksheets(1).Range(strAddress)
    If Not r Is Nothing Then ValidAddress = True
End Function
Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long


    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0


    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function
Sub copymasterdata()
Dim mastersh As Worksheet
Dim mastershstr As String
Dim receptor1wb As Workbook
Dim receptor1wbpath As String
Dim receptorsh1 As Worksheet
Dim receptorsh1str As String
Dim lastrow1 As Long
Dim masterdatacells As String
Dim recept1cols As String
Dim masterunbound As Variant
Dim recept1unbound As Variant
Dim receptstr As String
Dim maststr As String
Dim i As Long
Dim errmsg As String
Dim clearer As Long
Dim uidcol As String
Dim uidnum As Long
Dim dupes As String
Dim filldwnrng As String
Dim editon As Long
Dim editprompt As String


Application.DisplayAlerts = True
Application.ScreenUpdating = True


'****SETTINGS/CONFIGURATIONS*****
mastershstr = "sheet1" 'actual sheet name of the master sheet within this workbook
receptor1wbpath = "" 'full path of receptor1 workbook or leave blank to use same as master workbook
receptorsh1str = "sheet2" 'actual sheet name of the receptor sheet
masterdatacells = "A3, B3, C3, D3, E3, G3, H3, I3, J3, L3, M3, N3, O3, P3, Q3, R3, S3" 'these are the cells on the master sheet that will be copied
recept1cols = "A, B, C, D, E, G, H, I, J, L, M, N, O, P, Q, R, S" 'these the the columns to copy to on the receptor sheet
clearer = 0 'set to 1 to clear the master sheet entries after each run
uidcol = "" 'set to column letter of uid. Should also be first letter in recept1cols even if not in order.
uidon = 0 'set to 1 to use auotmated unique ID
editon = 0 'set to 1 to activate editing of existing entry. Must use with uidcol and uidon
'***********************


'========NOTES===============
'1. Set/Configure only the Settings/Configurations above.
'2. All receptor1cols need corresponding masterdatacells even if no data is being entered into a masterdatacell.
'3. Will look at cells to see if formula; if on receptor sheet will drag down to next record row. If on master will not overwrite.
'4. Setting uidon to 1 will cause to assign automatic uid in form of sequential number starting at 1, 2, 3 and so on. This will populate the
    'uidcol on the receptor sheet.
'----rodericke.com/excelDB---
'============================


'error trapping
If Trim(mastershstr) = "" Then
errmsg = "Press alt+F11 and set mastershstr to the actual name of the master sheet"
End If
If Trim(receptorsh1str) = "" Then
errmsg = "Press alt+F11 and set receptorsh1str to the actual name of the receptor sheet"
End If
If receptor1wbpath = "" Then
receptor1wbpath = ThisWorkbook.FullName
End If
If Dir(receptor1wbpath) = Empty Then
errmsg = "Press alt+F11 and set receptor1wbpath to the full pathway name of the receptor workbook, including the extension such as .xls or .xlxs"
End If
If editon = 1 And uidcol = "" Then
errmsg = "Press alt+F11 and set " & vbCr & "uidcol"
End If
If uidon = 1 And uidcol = "" Then
errmsg = "Press alt+F11 and set " & vbCr & "uidcol"
End If
If errmsg <> "" Then
MsgBox errmsg, vbCritical, "ERROR"
Exit Sub
End If
'--------------------




'set worbooks and sheets, open receptor workbook if needed
Set mastersh = Worksheets(mastershstr)
If IsWorkBookOpen(receptor1wbpath) Then
Application.ScreenUpdating = False
Set receptor1wb = Workbooks(Dir(receptor1wbpath))
Else
Set receptor1wb = Workbooks.Open(receptor1wbpath)
End If
Set receptorsh1 = receptor1wb.Worksheets(receptorsh1str)






'check for valid addresses and matching receptor1cols
masterunbound = Split(masterdatacells, ",")
recept1unbound = Split(recept1cols, ",")
If UBound(masterunbound) <> UBound(recept1unbound) Then
MsgBox "The master columns and the receptor1 columns aren't the same count." & vcbr & " Perhaps there is a missing comma", vbCritical, "ALERT"
Exit Sub
End If
For i = LBound(masterunbound) To UBound(masterunbound)
If ValidAddress(Trim(masterunbound(i))) = False Then
If errmsg = "" Then
errmsg = Trim(masterunbound(i))
Else
errmsg = errmsg & vbCr & Trim(masterunbound(i))
End If
End If
Next i
If errmsg <> "" Then
MsgBox "The following master cell addresses are invalid (may require comma):" & vbCr & "-----------------------" & vbCr & errmsg, vbCritical, "ALERT"
Exit Sub
End If




'unfilter receptor sheet if filtered -- make for each receptor sheet next 3 lines, change numbers
If receptorsh1.AutoFilterMode Then
receptorsh1.Cells.AutoFilter
End If


'determine last row of each receptorsheet -- make for each receptor sheet change numbers
lastrow1 = 1
On Error Resume Next
lastrow1 = receptorsh1.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1
Resume Next ' if no data on sheet
masterunbound = Split(masterdatacells, ",")
recept1unbound = Split(recept1cols, ",")
For i = LBound(masterunbound) To UBound(masterunbound)
receptstr = Trim(recept1unbound(i))
maststr = Trim(masterunbound(i))


'do uid check. Set UIDCOL at beginning of code
If Trim(uidcol) <> "" Then
If receptstr = uidcol Then
If IsError(Application.Match(mastersh.Range(maststr), receptorsh1.Range(receptstr & ":" & receptstr), 0)) = False Then
dupes = mastersh.Range(maststr)
GoTo ender:
Exit Sub
End If
End If
End If


'add new record
If receptorsh1.Cells(lastrow1 - 1, receptstr).HasFormula Then
filldwnrng = receptorsh1.Cells(lastrow1 - 1, receptstr).Address & ":" & receptorsh1.Cells(lastrow1, receptstr).Address
receptorsh1.Range(filldwnrng).FillDown
Else
'add uidnum
If Trim(uidcol) <> "" And uidon = 1 And receptstr = uidcol Then
uidnum = Application.Max(receptorsh1.Range(uidcol & ":" & uidcol)) 'get last uid
receptorsh1.Cells(lastrow1, receptstr) = uidnum + 1
Else
'add as is
receptorsh1.Cells(lastrow1, receptstr) = mastersh.Range(maststr)
End If
dupes = "Copied"
End If
If clearer = 1 Then
If mastersh.Range(maststr).HasFormula = False Then
mastersh.Range(maststr) = "" 'only clear if not formula
End If
End If
Next i


ender:
If editon = 0 And uidcol <> "" Then
If dupes <> "Copied" Then
dupes = "Duplicate UID not added:" & vbCr & "------------------" & vbCr & dupes
Else
End If
End If


If editon = 1 Then
If dupes <> "Copied" Then
If Trim(dupes) <> "" Then
editprompt = InputBox(dupes & " already exists. " & vbCr & "What would you like to do with this record? " & vbCr & "Input [d]isplay or [e]dit", "DISPLAY OR EDIT?", "Display")
If Left(editprompt, 1) = "e" Then
lastrow1 = Application.Match(mastersh.Range(maststr), receptorsh1.Range(receptstr & ":" & receptstr), 0)
dupes = "Updated record: " & vbCr & dupes & vbCr & "on row " & lastrow1 & " of " & vbCr & receptor1wb.Name & "[" & receptorsh1.Name & "]"
For i = LBound(masterunbound) To UBound(masterunbound)
receptstr = Trim(recept1unbound(i))
maststr = Trim(masterunbound(i))
If receptorsh1.Cells(lastrow1 - 1, receptstr).HasFormula Then
filldwnrng = receptorsh1.Cells(lastrow1 - 1, receptstr).Address & ":" & receptorsh1.Cells(lastrow1, receptstr).Address
receptorsh1.Range(filldwnrng).FillDown
Else
receptorsh1.Cells(lastrow1, receptstr) = mastersh.Range(maststr)
End If
If clearer = 1 Then
If mastersh.Range(maststr).HasFormula = False Then
mastersh.Range(maststr) = "" 'only clear if not formula
End If
End If
Next i
End If


If Left(editprompt, 1) = "d" Then
lastrow1 = Application.Match(mastersh.Range(maststr), receptorsh1.Range(receptstr & ":" & receptstr), 0)
For i = LBound(masterunbound) To UBound(masterunbound)
receptstr = Trim(recept1unbound(i))
maststr = Trim(masterunbound(i))
If mastersh.Range(maststr).HasFormula = False Then
mastersh.Range(maststr) = "" 'clear first if not formula
mastersh.Range(maststr) = receptorsh1.Cells(lastrow1, receptstr)
End If
Next i
Exit Sub 'no edit
End If
End If
End If


If editprompt = "" Then 'if cancel selected
If dupes <> "Copied" Then
Exit Sub
End If
End If
End If






If receptor1wb.Name <> ThisWorkbook.Name Then 'in case using same workbook as master
Application.DisplayAlerts = False
If receptor1wb.ReadOnly Then
receptor1wb.Close SaveChanges:=False
dupes = receptor1wb.Name & " is READ-ONLY. " & vbCr & "Try again in a moment"
Else
receptor1wb.Close SaveChanges:=True
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
MsgBox dupes, vbInformation, "CONFIRMATION"


End Sub