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
Dim donesome As Long
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'****SETTINGS/CONFIGURATIONS*****
mastershstr = "sheet1" 'actual sheet name of the master sheet within this workbook
receptor1wbpath = "C:\Users\redwards\Desktop\Testwbkdb.xlsx" '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
Application.ScreenUpdating = False
Set mastersh = Worksheets(mastershstr)
If IsWorkBookOpen(receptor1wbpath) Then
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
mastersh.Range(maststr) = uidnum + 1
Else
'add as is
receptorsh1.Cells(lastrow1, receptstr) = mastersh.Range(maststr)
If Trim(mastersh.Range(maststr)) <> "" Then
donesome = 1 'indicate something copied
End If
End If
If uidnum > 0 Then
dupes = "Copied (UID=" & uidnum + 1 & ")"
Else
dupes = "Copied"
End If
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 InStr(dupes, "Copied") = 0 Then
dupes = "Duplicate UID not added:" & vbCr & "------------------" & vbCr & dupes
donesome = 1 'indicate something copied
Else
End If
End If
If editon = 1 Then
If InStr(dupes, "Copied") = 0 Then
If Trim(dupes) <> "" Then
'close until selection made
If ThisWorkbook.Name <> receptor1wb.Name Then
receptor1wb.Close SaveChanges:=False
End If
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
'attempt to reopen selection made
If ThisWorkbook.Name <> receptor1wb.Name Then
Set receptor1wb = Workbooks.Open(receptor1wbpath)
Set receptorsh1 = receptor1wb.Worksheets(receptorsh1str)
End If
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 & "]"
donesome = 1 'indicate something copied
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
'attempt to reopen selection made
If ThisWorkbook.Name <> receptor1wb.Name Then
Set receptor1wb = Workbooks.Open(receptor1wbpath, ReadOnly)
Set receptorsh1 = receptor1wb.Worksheets(receptorsh1str)
End If
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
'close since only display
If ThisWorkbook.Name <> receptor1wb.Name Then
receptor1wb.Close SaveChanges:=False
End If
Exit Sub 'no edit
End If
End If
End If
If editprompt = "" Then 'if cancel selected
If InStr(dupes, "Copied") = 0 Then
Application.ScreenUpdating = True
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"
donesome = 1 'indicate something happened
Else
receptor1wb.Close SaveChanges:=True
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
If donesome = 1 Then
Application.ScreenUpdating = True
MsgBox dupes, vbInformation, "CONFIRMATION"
End If
End Sub
