I'm stuck trying to delete a row in a table after copying and pasting it to another Workbook table. It worked when I was activating workbooks and sheets but now has stopped. Can this be done the way I have the code now? Any help is greatly appreciated. I have been trying to fix this for two days now..
Sub MoveOrdertoDelivery()
'
' Move_Order Macro
' Move the next line on the Delivery Log for the day
'
'*************************************************************************
' New Code for MoveLinetoDeliverySchedule
'*************************************************************************
Dim copyrng As Range
Dim rngOld As Range
Dim msgRes As VbMsgBoxResult
Dim checkcellrange As Range
Dim strFileDir As String
' new to use the better code****DELETE AFTER IT WORKS
Dim destinationSheetName As String
Dim originatingWorkbookName As String
Dim originatingWorkbook As Workbook
Dim destinationWorkbook As Workbook
Dim originatingSheetName As String
Dim destinationFileName As String
Dim originatingTableName As String
Dim destinationTableName As String
strFileDir = ThisWorkbook.Path
originatingWorkbookName = ActiveWorkbook.Name
originatingSheetName = ActiveSheet.Name
destinationFileName = strFileDir & "\Door Delivery Schedule.xlsm"
Set checkcellrange = Range("A1:ZZ3")
Set rngOld = ActiveCell
Set originatingWorkbook = Workbooks.Open(strFileDir & "\" & originatingWorkbookName)
ActiveSheet.Cells(ActiveCell.Row, 1).Select
Set copyrng = Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 11))
copyrng.Select
If Intersect(checkcellrange, copyrng) Is Nothing Then
originatingTableName = ActiveCell.ListObject.Name
Else
msgRes = MsgBox("Please select a table Row!", vbOKCancel)
Exit Sub
End If
If Intersect(checkcellrange, rngOld) Is Nothing Then
If Not allBlank(ThisWorkbook.Sheets(originatingSheetName).Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 11))) Then
msgRes = MsgBox("Proceed?", vbOKCancel, "You are about to Move this row to the Door Delivery Schedule.")
If msgRes = vbOK Then
Selection.Copy
On Error Resume Next
tablerow = Selection.Row - Selection.ListObject.Range.Row
If Err.Number = 91 Then
MsgBox "Please select a line with data in it!"
Exit Sub
End If
'originatingWorkbook.Sheets(originatingSheetName).Range(ListObjects(originatingTableName).ListRows(tablerow)).Copy
'originatingWorkbook.Sheets(originatingSheetName).Range(copyrng).Copy
Set destinationWorkbook = Workbooks.Open(destinationFileName)
destinationWorkbook.Sheets("Orders For Delivery").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
destinationWorkbook.Save
destinationWorkbook.Close
'originatingWorkbook.Sheets(originatingSheetName).Selection.Delete Shift:=
Windows("Production Schedule Main.xlsm").Activate
Sheets("Completed Orders").Activate
copyrng.Select
originatingWorkbook.Sheets(originatingSheetName).Selection.ListObject.ListRows(tablerow).Delete
Selection.Delete Shift:=x1Up
Exit Sub
Else
End If
Else
MsgBox ("Please select a row with data in it.")
End If
Else
MsgBox ("Please select a legal row in the field.")
End If
End Sub
Related
I am new to VBA.
Thank you for your time. I have been Googling for 2 days and always get an error.
I have two sheets
Projects ( where I will store project names) and
Template (where new projects will be created using the "template" sheet)
I have 2 issues I am trying to solve :
How do I copy the format on an active sheet including conditional formatting and column width. PasteSpecial already copies all the colour design but not the column width/conditional formatting
When I run the code it creates a new sheet called Project Name,not sure where that is coming from.
This is the code I am using:
Sub Copy()
Sheets("Template").Range("A1:O100").Copy
ActiveSheet.PasteSpecial
End Sub
<<<<<<<<<<<<<<<<<<<<<<
I want to generate a project name, make sure it does not exist(no duplicate), open a new sheet and copy the template from "template".
The full codes is:
RunAll()
CreateProjectName
CreateNewTab
CopyPaste
End Sub
Dim AddData As Range
Dim AddName As String
Set AddData = Cells(Rows.Count, 4).End(xlUp).Offset(1, 0)
AddName = InputBox("Enter Project Name do not input manually", "Project Monitor")
If AddName = "" Then Exit Sub
AddData.Value = AddName
AddData.Offset(0, 1).Value = Now
End Sub
Function SheetCheck(sheet_name As String) As Boolean
Dim ws As Worksheet
SheetCheck = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = sheet_name Then
SheetCheck = True
End If
Next
End Function
Sub CreateNewTab()
Dim sheets_count As Integer
Dim sheet_name As String
Dim i As Integer
sheet_count = Range("D3:D1000").Rows.Count
For i = 1 To sheet_count
sheet_name = Sheets("Projects").Range("D3:D1000").Cells(i, 1).Value
If SheetCheck(sheet_name) = False And sheet_name <> "" Then
Worksheets.Add(After:=Sheets("Projects")).Name = sheet_name
End If
Next i
End Sub
Sub CopyPaste()
Sheets("Template").Range("A1:o100").Copy
ActiveSheet.PasteSpecial
End Sub
Option Explicit
Sub AddProject()
Dim ws As Worksheet, NewName As String
NewName = InputBox("Enter Project Name do not input manually", "Project Monitor")
' checks
If NewName = "" Then
MsgBox "No name entered", vbCritical
Exit Sub
Else
' check sheet not existing
For Each ws In ThisWorkbook.Sheets
If UCase(ws.Name) = UCase(NewName) Then
MsgBox "Existing Sheet '" & ws.Name & "'", vbCritical, "Sheet " & ws.Index
Exit Sub
End If
Next
End If
' check not existing in list
Dim wb As Workbook, n As Long, lastrow As Long, v
Set wb = ThisWorkbook
With wb.Sheets("Projects")
lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row
v = Application.Match(NewName, .Range("D1:D" & lastrow), 0)
' not existing add to list
If IsError(v) Then
.Cells(lastrow + 1, "D") = NewName
.Cells(lastrow + 1, "E") = Now
Else
MsgBox "Existing Name '" & NewName & "'", vbCritical, "Row " & v
Exit Sub
End If
End With
' create sheet
n = wb.Sheets.Count
wb.Sheets("Template").Copy after:=wb.Sheets(n)
wb.Sheets(n + 1).Name = NewName
MsgBox NewName & " added as Sheet " & n + 1, vbInformation
End Sub
I'm very new to VBA and I'm working on a project where I've got multiple Excel files in a folder, each structured the same way, and I want to loop through each of them, search for specific terms in each single file, copy it, and paste it to the master-file in a specific way.
I already got everything except pasting it the right way:
Every term it finds in a source-file should be posted to the next empty column in the master file and for each new source-file the loop goes through, it should post the stuff it finds to a new row in the master file.
Below is what I've already got.
Private Const sPath As String = "F:\ExamplePath"
Sub LoopThroughFiles()
Dim sFile As String 'File Name
Dim sExt As String 'File extension
sExt = "xlsx"
'loop through each file name and open it if the extension is correct
sFile = Dir(sPath)
Do Until sFile = ""
If Right(sFile, 4) = sExt Then GetInfo sFile
sFile = Dir
Loop
End Sub
Private Sub GetInfo(sFile As String)
Dim wbFrom As Workbook 'workbook to copy the data from
Dim iRow As Integer 'row number of next empty row
Dim cl As Range
Dim strAddress As String
On Error GoTo errHandle
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wbFrom = Workbooks.Open(sPath & sFile)
'finds Search-Term
With wbFrom.Sheets(1).Cells
Set cl = .Find("necrosis_left", After:=.Range("C2"), LookIn:=xlValues)
If Not cl Is Nothing Then
strAddress = cl.Address
cl.Select
Selection.Copy
iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells
End If
End With
'finds other Search-Term
With wbFrom.Sheets(1).Cells
Set cl = .Find("necrosis_right", After:=.Range("C2"), LookIn:=xlValues)
If Not cl Is Nothing Then
strAddress = cl.Address
cl.Select
Selection.Copy
iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells
End If
End With
'many more search terms
wbFrom.Close (False)
Application.EnableEvents = True
Application.ScreenUpdating = True
Set wbFrom = Nothing
Exit Sub
errHandle:
MsgBox Err.Description
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
So I do know, that my problem is located here:
iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells
But I can't quite figure out how it posts to an empty column instead of an empty row, not to speak of how to make it go down a row in the master file for each new source file.
Found the answer to my own question!
The first step was to replace the "paste-line" above with the following:
Me.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteAll
This pastes every copied cell to the next empty column in line 1.
To start a new line for every source-file the loop goes through, a public variable had to be declared, which counted up each iteration. The final code looks like this:
Private Const sPath As String = 'enter your path
Public Zeile As Integer 'public variable
Sub LoopThroughFiles()
Dim sFile As String 'File Name
Dim sExt As String 'File extension you wish to open
Zeile = 1 'important for not start pasting in row 0 (which is impossible)
sExt = "xlsx" 'Change this if extension is different
'loop through each file name and open it if the extension is correct
sFile = Dir(sPath)
Do Until sFile = ""
If Right(sFile, 4) = sExt Then GetInfo sFile
sFile = Dir
Zeile = Zeile + 1 'goes up each iteration
Loop
End Sub
Private Sub GetInfo(sFile As String)
Dim wbFrom As Workbook 'workbook to copy the data from
Dim iRow As Integer 'row number of next empty row
Dim cl As Range
Dim strAddress As String
On Error GoTo errHandle
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wbFrom = Workbooks.Open(sPath & sFile)
'copy the following block for each term you want to search for
With wbFrom.Sheets(1).Cells
Set cl = .Find("searchterm", After:=.Range("C2"), LookIn:=xlValues)
If Not cl Is Nothing Then
strAddress = cl.Address
cl.Select
Selection.Copy
Me.Cells(Zeile, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteAll 'the rows are controlled via the public variable
End If
End With
wbFrom.Close (False)
Application.EnableEvents = True
Application.ScreenUpdating = True
Set wbFrom = Nothing
Exit Sub
errHandle:
MsgBox Err.Description
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The result loops through all files of a folder, searches for a specific term and pastes each result in the next empty column of the master file, but starts a new row for each source file.
Thanks though!
I need to create copies of entire workbooks (as there are other sheets, formatting, etc. I want to preserve) and then delete out rows of data that do not equal the current cl.value. The column headers will always be in row 1. The worksheet can have a varying amount of columns (i.e. A:D, A:F, A:G, etc.) and the end user can select any column to split by.
Referencing a cell works but if try to make it dynamic (based on user selection mentioned above) in the following part of the code:
Workbooks.Open Filename:=FName
'Delete Rows
'REFERENCING ACTUAL CELL WORKS
'Range("A1").AutoFilter 1, "<>" & cl.Value
'BELOW DOES NOT WORK
Range(ColHead).AutoFilter 1, "<>" & cl.Value
I get a
Run-time error '1004': Method 'Range' of object'_Global' Failed
Full Code Below:
Sub DisplayUserFormSplitWb()
UserFormSplitWb.Show
End Sub
Private Sub BtnOK_Click()
Call SplitWbMaster.SplitWbToFiles
End Sub
Private Sub UserForm_Initialize()
Dim SplitOptions As Range
Set SplitOptions = ActiveSheet.Range("A1", ActiveSheet.Range("A1").End(xlToRight))
SplitWbCol.List = Application.Transpose(SplitOptions.Value)
End Sub
Sub SplitWbToFiles()
Dim cl As Range
Dim OrigWs As Worksheet
Dim Subtitle As String
Dim ColValue As String
Dim ColStr As String
Dim ColNum As Long
Set OrigWs = ActiveSheet
ColValue = UserFormSplitWb.SplitWbCol.Value
Set ColHead = Rows(1).Find(What:=ColValue, LookAt:=xlWhole)
Set OffCol = ColHead.Offset(1, 0)
ColStr = Split(ColHead.Address, "$")(1)
ColNum = ColHead.Column
If OrigWs.FilterMode Then OrigWs.ShowAllData
With CreateObject("scripting.dictionary")
For Each cl In OrigWs.Range(OffCol, OrigWs.Range(ColStr & Rows.Count).End(xlUp))
If Not .exists(cl.Value) Then
.Add cl.Value, Nothing
'Turn off screen and alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Create workbook copy
FPath = "U:\"
Subtitle = UserFormSplitWb.SplitWbSubtitle.Value
FName = FPath & cl.Value & "_" & Subtitle & ".xlsx"
ActiveWorkbook.SaveCopyAs Filename:=FName
Workbooks.Open Filename:=FName
'Delete Rows
'REFERENCING ACTUAL CELL WORKS
'Range("A1").AutoFilter 1, "<>" & cl.Value
'BELOW DOES NOT WORK
Range(ColHead).AutoFilter 1, "<>" & cl.Value
ActiveSheet.ListObjects(1).DataBodyRange.Delete
Range(ColHead).AutoFilter
Range(ColHead).AutoFilter
'Rename sheet
ActiveSheet.Name = Left(cl.Value, 31)
'Refresh save and close
ActiveWorkbook.RefreshAll
ActiveWorkbook.Save
ActiveWorkbook.Close False
End If
Next cl
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Splitting is complete. Please check your Computer (U:) drive.", vbOKOnly, "Run Macro"
End Sub
To anyone who might stumble upon this question -
I have found that using the below code solves my issue:
ActiveSheet.Range("A1", ActiveSheet.Range("A1").End(xlToRight)).AutoFilter ColNum, "<>" & cl.Value
where:
Dim ColNum As Long
ColNum = ColHead.Column
This code is for updating client information in my source document for a mail merge from a list that I can pull from my client server at any time.
I've hit a snag in this code near the end. The process it currently goes through is as follows:
user selects the merge document that needs to be updated
user selects the list with the updated addresses
code steps through the merge document, grabs the name of a company, then
searches through the second document for that company, copies the address information from the list, and
pastes it next to the company name in the merge document and
starts over with the next company name in the merge document
I'm currently stuck between steps four and five.'
here's a selection of the code I'm trying to adapt to search the source workbook, but I think this isn't going to work - I need to paste the found term into the macro workbook, and I have a gap in my knowledge of VBA here.
I can post my full code if necessary, but I didn't want to throw the whole thing in right away.
Thanks in advance!
Set sourcewkb = ActiveWorkbook
Dim rnnng As Range
Dim searchfor As String
Debug.Print celld
searchfor = celld
Set rnnng = Selection.Find(what:=searchfor)
If rnnng Is Nothing Then
Debug.Print "yes"
Else
Debug.Print "no"
End If
EDIT
I tried some of what was suggested in the comment, but I'm having an issue where the selection.find is finding the variable in question whether or not it's actually there. I think somehow it's searching in both workbooks?
Full code (some parts are marked out as notes for convenience during editing the code, they generally aren't the parts I'm concerned about):
UPDATED full code:
Sub addressfinder()
Dim rCell
Dim rRng As Range
Dim aftercomma As String
Dim celld As String
Dim s As String
Dim indexOfThey As Integer
Dim mrcell As Range
Dim alreadyfilled As Boolean
Dim nocompany As Boolean
Dim sourcewkb
Dim updaterwkb
Dim fd As FileDialog
Dim cellstocopy As Range
Dim cellstopaste As Range
Dim x As Byte
'select updater workbook
updaterwkb = "L:\Admin\Corporate Books\2015\letter macro\Annual Consent Letter Macro.xlsm"
'this is the finished updater workbook selecter.
' Set fd = Application.FileDialog(msoFileDialogFilePicker)
'
'
' Dim vrtselecteditem As Variant
' MsgBox "select the Annual Consent Letter Macro workbook"
'
' With fd
' If .Show = -1 Then
' For Each vrtselecteditem In .SelectedItems
'
'
' updaterwkb = vrtselecteditem
' Debug.Print updaterwkb
' Next vrtselecteditem
' Else
' End If
' End With
'select file of addresses
sourcewkb = "L:\Admin\Corporate Books\2015\letter macro\source workbook_sample.xlsx"
'this is the finished source select code
' Dim lngcount As Long
' If MsgBox("Have you gotten this year's updated contact list exported from Time Matters or Outlook?", vbYesNo, "confirm") = vbYes Then
' If MsgBox("Is the information in that excel workbook formatted per the instructions?", vbYesNo, "Confirm") = vbYes Then
' MsgBox "Good. Select that workbook now."
' Else
' MsgBox "Format the workbook before trying to update the update list"
' End If
' Else
' MsgBox "Have someone export you a client list with company name, client name, and client address"
'
' End If
'
'
' With Application.FileDialog(msoFileDialogOpen)
' .AllowMultiSelect = False
' .Show
' For lngcount = 1 To .SelectedItems.Count
' Debug.Print .SelectedItems(lngcount)
' sourcewkb = .SelectedItems(lngcount)
'
' Next lngcount
' End With
'
Workbooks.Open (sourcewkb)
'start the code
Set updaterwkb = ActiveWorkbook
Set rRng = Sheet1.Range("a2:A500")
For Each rCell In rRng.Cells
'boolean resets
alreadyfilled = False
nocompany = False
'setting up the step-through
s = rCell.Value
indexOfThey = InStr(1, s, ",")
aftercomma = Right(s, Len(s) - indexOfThey + 1)
celld = Left(s, Len(s) - Len(aftercomma))
Debug.Print rCell.Value, "celld", celld
Debug.Print "address", rCell.Address
'setting up already filled check
Set mrcell = rCell.Offset(rowoffset:=0, ColumnOffset:=6)
Debug.Print "mrcell", mrcell.Value
If Len(rCell.Formula) = 0 Then
Debug.Print "company cell sure looks empty"
nocompany = True
End If
If Len(mrcell.Formula) > 0 Then
Debug.Print "mrcell has content"
alreadyfilled = True
Else: Debug.Print "mrcell has no content"
End If
If alreadyfilled = False Then
If nocompany = False Then
'the code for copying stuff
'open source document
'search source document for contents of celld
'if contents of celld are found, copy everything to the right of the cell in which
'they were found and paste it horizontally starting at mrcell
'if not, messagebox "address for 'celld' not found
'Set sourcewkb = ActiveWorkbook
'
'Dim rnnng As Range
'Dim searchfor As String
'Debug.Print celld
'searchfor = celld
'
'Set rnnng = Selection.Find(what:=searchfor)
'If Not rnnng Is Nothing Then
' Debug.Print "yes"
' Else
' Debug.Print "no"
'
'End If
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim company As String
Dim lastRow As Long
Dim rng As Variant
Dim llc As String
Dim inc As String
Dim searchfor As String
Set wb1 = ThisWorkbook
Set wb2 = Workbooks("source workbook_sample.xlsx") 'change workbook name
Set ws1 = ThisWorkbook.Worksheets(1) 'change worksheet #
Set ws2 = wb2.Worksheets(1) 'change worksheet #
llc = ",LLC"
inc = ",INC."
'lastRow = ws1.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
With ws1
For i = 1 To 500
If Cells(i, 1).Value = searchfor Then
company = .Cells(i, 1)
With ws2
'change range as necessary
Set f = .Range("A1:D100").Find(company, LookIn:=xlValues)
If Not f Is Nothing Then
Debug.Print searcfor
fRow = f.Row
rng = .Range("B" & fRow & ":D" & fRow)
ws1.Range("B" & i & ":D" & i) = rng
End If
End With
End If
Next
End With
'
Else
Debug.Print "skipped cuz there ain't no company"
End If
Else
Debug.Print "skipped cuz it's filled"
End If
''
'
Debug.Print "next"
Next rCell
End Sub
fixed code:
With ws1
For i = 1 To 500
If Cells(i, 1).Value = searchfor Then
company = .Cells(i, 1)
With ws2
'change range as necessary
Set f = .Range("A1:D100").Find(company, LookIn:=xlValues)
If Not f Is Nothing Then
Debug.Print searcfor
fRow = f.Row
rng = .Range("B" & fRow & ":D" & fRow)
ws1.Range("B" & i & ":D" & i) = rng
End If
End With
End If
Next
End With
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim company As String
Dim lastRow As Long
Dim rng As Variant
Dim llc As String
Dim inc As String
Dim searchfor As String
Set wb1 = ThisWorkbook 'Annual Consent Letter Macro
Set wb2 = Workbooks("source workbook_sample.xlsx")
Set ws1 = ThisWorkbook.Worksheets(1)
Set ws2 = wb2.Worksheets(1)
llc = ",LLC"
inc = ",INC."
With ws1
For i = 1 To 500
If Cells(i, 1).Value = searchfor Then
company = .Cells(i, 1)
With ws2
'change range as necessary
Set f = .Range("A1:A500").Find(company, LookIn:=xlValues)
If Not f Is Nothing Then
Debug.Print searcfor
fRow = f.Row
rng = .Range("B" & fRow & ":D" & fRow)
ws1.Range("B" & i & ":D" & i) = rng
End If
End With
End If
Next
End With
End Sub
I have three macros in my workbook that work fine. However, when I protect any of the worksheets, they stop to work and I get a run-time error 1004.
I have tried following the two suggestions that I found online:
Unprotect at start of macro code, and protect at end;
User Interface Only) but the run-time error remains.
I need my Workbook to be protected and for my macros to function, what shall I do?
Macro 1:
Sub Macro1()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myCopy As Range
Dim myTest As Range
Dim lRsp As Long
Set inputWks = Worksheets("Visit & Order Entry Form")
Set historyWks = Worksheets("Visit & Order Database")
'check for duplicate order ID in database
If inputWks.Range("CheckID2") = True Then
lRsp = MsgBox("Clinic ID already in database. Update database?", vbQuestion + vbYesNo, "Duplicate ID")
If lRsp = vbYes Then
UpdateLogRecord
Else
MsgBox "Please change Clinic ID to a unique number."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("OrderEntry2")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
myCopy.Copy
.Cells(nextRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With myCopy.Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
End If
End Sub
Macro 2
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myCopy As Range
Dim myTest As Range
Dim lRsp As Long
Set inputWks = Worksheets("Visit & Order Entry Form")
Set historyWks = Worksheets("Contact Details & Segm Database")
'check for duplicate order ID in database
If inputWks.Range("CheckID") = True Then
lRsp = MsgBox("Clinic ID already in database. Update database?", vbQuestion + vbYesNo, "Duplicate ID")
If lRsp = vbYes Then
UpdateLogRecord
Else
MsgBox "Please change Clinic ID to a unique number."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("OrderEntry")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
myCopy.Copy
.Cells(nextRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With myCopy.Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(52) ', Scroll:=True
End With
On Error GoTo 0
End With
End If
End Sub
Macro 3
Sub UpdateLogRecord()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim lRec As Long
Dim oCol As Long
Dim lRecRow As Long
Dim myCopy As Range
Dim myTest As Range
Dim lRsp As Long
Set inputWks = Worksheets("Visit & Order Entry Form")
Set historyWks = Worksheets("Contact Details & Segm Database")
'check for duplicate order ID in database
If inputWks.Range("CheckID") = False Then
lRsp = MsgBox("Clinic ID not in database. Add clinic to database?", vbQuestion + vbYesNo, "New Order ID")
If lRsp = vbYes Then
UpdateLogWorksheet
Else
MsgBox "Please select Clinic ID that is in the database."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("OrderEntry")
lRec = inputWks.Range("CurrRec").Value
lRecRow = lRec + 1
With inputWks
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
With .Cells(lRecRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(lRecRow, "B").Value = Application.UserName
oCol = 3
myCopy.Copy
.Cells(lRecRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With myCopy.Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(52) ', Scroll:=True
End With
On Error GoTo 0
End With
End If
End Sub
You don't have any code in there to unprotect at the start of the macro and then protect again at the end. You need something like this at the start (I think you already know this but just trying to be clear).
SheetName.Unprotect Password:=yourPassword
And this at the end:
SheetName.Protect Password:=yourPassword
You say you've tried this already but it's not clear from the code you posted where you had these commands.
From trying to reproduce the behaviour at this end I notice you have two different worksheets you refer to as historyWks which could be causing problems with locking and unlocking.
One option is to unprotect all worksheets at your entry point then protect them again at the exit.
Private Const yourPassword As String = "password"
Sub UnprotectAll()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
sh.Unprotect Password:=yourPassword
Next sh
End Sub
Sub ProtectAll()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
sh.Protect Password:=yourPassword
Next sh
End Sub
You just need to call these at the start and end of your Macro1. You might also want to add an Application.ScreenUpdating = False at the start to avoid flicker as it loops through all the worksheets and then Application.ScreenUpdating = True at the end of Macro1.
help for macro beginners:
if you are using a button to run a macro,
include the following inside sub buttonclick()
Dim sh As Worksheet
Dim yourPassword As String
yourPassword = "whatever password you like"
For Each sh In ActiveWorkbook.Worksheets
sh.Unprotect Password:=yourPassword
"now enter your macro which needs to be run
,at the end , before end sub paste the below line
For Each sh In ActiveWorkbook.Worksheets
sh.Protect Password:=yourPassword
Next sh