How to shorten vba code without any problems

K

kamranyd

Board Regular
Joined
Apr 24, 2018
Messages
152
Office Version
  1. 2021
Platform
  1. Windows
Can we shorten these codes with any problems. So it can execute more quick.

VBA Code: 
Private Sub custnameonlysave_Click()
Dim CustRow As Long
Sheets("lists").Unprotect
Range("C8").MergeArea.ClearContents
    If Me.custnameonlytextBox.Value = Empty Then
        MsgBox "Please add customer name before saving", vbCritical, "Add Customer Name"
        Exit Sub
    End If
    
    With Sheet1
         If IsEmpty(Sheet2.Range("C8").Value) Then    'New Customer
         CustRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1  'First avail Row
    End If
       .Cells(CustRow, "A").Value = Me.custnameonlytextBox.Value
       .Cells(CustRow, "A").Locked = False
    End With
        
        CustNameOnly.Hide
        Sheet2.Range("C8").Value = custnameonlytextBox.Value    'Set Customer Name
        'Sheets("lists").Protect
End Sub
Quote ReplyReport
Sort by date Sort by votes
kamranyd
Board Regular
Sunday at 3:15 PM
Add bookmark
#2
kamranyd said:
these codes paste value at the last available row in column A, but i also want to copy above cell values which are in cell B, C, D columns down last row also?

VBA Code:
P
rivate Sub custnameonlysave_Click()
Dim CustRow As Long
Sheets("lists").Unprotect
Range("C8").MergeArea.ClearContents
    If Me.custnameonlytextBox.Value = Empty Then
        MsgBox "Please add customer name before saving", vbCritical, "Add Customer Name"
        Exit Sub
    End If
  
    With Sheet1
         If IsEmpty(Sheet2.Range("C8").Value) Then    'New Customer
         CustRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1  'First avail Row
    End If
       .Cells(CustRow, "A").Value = Me.custnameonlytextBox.Value
       .Cells(CustRow, "A").Locked = False
    End With
      
        CustNameOnly.Hide
        Sheet2.Range("C8").Value = custnameonlytextBox.Value    'Set Customer Name
        'Sheets("lists").Protect
End Sub
Click to expand...any help
Quote ReplyReport
Upvote
0
<div class="blockMessage blockMessage--warning blockMessage--iconic"> CAUTION: We see that you are trying to mark your own post as the solution. Please be sure that you are marking the post that actually contains the solution. </div>
Cubist
Cubist
Well-known Member
Monday at 5:44 PM
Add bookmark
#3
Not tested. Try this on a copy.
VBA Code:
Private Sub custnameonlysave_Click()
    Dim CustRow As Long
    Dim wsLists As Worksheet
    Dim wsData As Worksheet
    
    Set wsLists = ThisWorkbook.Sheets("lists")
    Set wsData = ThisWorkbook.Sheets("Sheet1")
    
    wsLists.Unprotect
    
    wsLists.Range("C8").MergeArea.ClearContents
    
    If Me.custnameonlytextBox.Value = Empty Then
        MsgBox "Please add customer name before saving", vbCritical, "Add Customer Name"
        Exit Sub
    End If
    
    With wsData
        If IsEmpty(wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Value) Then
            CustRow = 1
        Else
            CustRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
        End If
        
        .Cells(CustRow, "A").Value = Me.custnameonlytextBox.Value
        .Cells(CustRow, "A").Locked = False
        
        If CustRow > 1 Then
            .Range(.Cells(CustRow - 1, "B"), .Cells(CustRow - 1, "D")).Copy Destination:=.Range(.Cells(CustRow, "B"), .Cells(CustRow, "D"))
        End If
    End With
    
    CustNameOnly.Hide
    
    wsLists.Range("C8").Value = Me.custnameonlytextBox.Value
    
    ' wsLists.Protect
    
End Sub
 Like Quote ReplyReport
Upvote
0
Mark as solution
kamranyd
Board Regular
Yesterday at 3:04 PM
Add bookmark
#4
figured out how to do it, but seems codes got long, can it be shorten without any problem.

Private Sub SaveBtn_Click()

Dim CustRow As Long, CustCol As Long
Dim CustomerFld As Control

Range("C8").MergeArea.ClearContents
Range("C9").MergeArea.ClearContents

Sheets("lists").Unprotect

If Me.Field1.Value = Empty Then
MsgBox "Please add customer name before saving.", vbCritical, "Add Customer Name"
Field1.BackColor = RGB(255, 204, 204)
Field1.SetFocus
Exit Sub
Else
Field1.BackColor = RGB(191, 254, 255)
End If

If Me.Field2.Value = Empty Then
MsgBox "Please add company name before saving.", vbCritical, "Add Company Name"
Field2.BackColor = RGB(255, 204, 204)
Field2.SetFocus
Exit Sub
Else
Field2.BackColor = RGB(191, 254, 255)
End If

If Me.Field3.Value = Empty Then
MsgBox "Please add company three alphabet abbreviation before saving.", vbCritical, "Add Company Initial"
Field3.BackColor = RGB(255, 204, 204)
Field3.SetFocus
Exit Sub
Else
Field3.BackColor = RGB(191, 254, 255)
End If

If Me.Field4.Value = "" Then
Else
If Not IsNumeric(Field4.Value) Then
MsgBox "Please enter number only in VATIN.", vbCritical, "Type Numbers Only"
Field4.BackColor = RGB(255, 204, 204)
Field4.SetFocus
Exit Sub
Else
Field4.BackColor = RGB(191, 254, 255)
End If
End If

If Me.Field8.Value = "" Then
Else
If Not IsNumeric(Field8.Value) Then
MsgBox "Please enter number only in Payments Terms.", vbCritical, "Type Numbers Only"
Field8.BackColor = RGB(255, 204, 204)
Field8.SetFocus
Exit Sub
Else
Field8.BackColor = RGB(191, 254, 255)
End If
End If

With Sheet1
If IsEmpty(Sheet2.Range("C8").Value) Then
CustRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End If
.Cells(CustRow, "A").Value = Me.Field1.Value
.Cells(CustRow, "B").FillDown
.Cells(CustRow, "C").FillDown
.Cells(CustRow, "D").FillDown
.Cells(CustRow, "A").Locked = False

If IsEmpty(Sheet2.Range("C9").Value) Then
CustRow = .Cells(.Rows.Count, "K").End(xlUp).Row + 1
End If
.Cells(CustRow, "K").Value = Me.Field2.Value
.Cells(CustRow, "L").FillDown
.Cells(CustRow, "M").FillDown
.Cells(CustRow, "N").FillDown
.Cells(CustRow, "K").Locked = False

For CustCol = 14 To 20
Set CustomerFld = Me.Controls("Field" & CustCol - 12)
.Cells(CustRow, CustCol).Value = CustomerFld.Value
Next CustCol
.Cells(CustRow, "N").Locked = False
.Cells(CustRow, "O").Locked = False
.Cells(CustRow, "P").Locked = False
.Cells(CustRow, "Q").Locked = False
.Cells(CustRow, "R").Locked = False
.Cells(CustRow, "S").Locked = False

CustDetails.Hide

Sheet2.Range("C8").Value = Field1.Value
Sheet2.Range("C9").Value = Field2.Value
MsgBox "Customer is added to Client Lists Database", vbInformation, "Customer is Added to Database."
Sheets("lists").Protect
End With
End Sub
Quote ReplyReport
Upvote
0
<div class="blockMessage blockMessage--warning blockMessage--iconic"> CAUTION: We see that you are trying to mark your own post as the solution. Please be sure that you are marking the post that actually contains the solution. </div>
kamranyd
Board Regular
Yesterday at 3:05 PM
Add bookmark
#5
I figured out how to do it, but seems codes got long, can it be shorten without any problem.

Code:
Private Sub SaveBtn_Click()

Dim CustRow As Long, CustCol As Long
Dim CustomerFld As Control

Range("C8").MergeArea.ClearContents
Range("C9").MergeArea.ClearContents

Sheets("lists").Unprotect

If Me.Field1.Value = Empty Then
MsgBox "Please add customer name before saving.", vbCritical, "Add Customer Name"
Field1.BackColor = RGB(255, 204, 204)
Field1.SetFocus
Exit Sub
Else
Field1.BackColor = RGB(191, 254, 255)
End If

If Me.Field2.Value = Empty Then
MsgBox "Please add company name before saving.", vbCritical, "Add Company Name"
Field2.BackColor = RGB(255, 204, 204)
Field2.SetFocus
Exit Sub
Else
Field2.BackColor = RGB(191, 254, 255)
End If

If Me.Field3.Value = Empty Then
MsgBox "Please add company three alphabet abbreviation before saving.", vbCritical, "Add Company Initial"
Field3.BackColor = RGB(255, 204, 204)
Field3.SetFocus
Exit Sub
Else
Field3.BackColor = RGB(191, 254, 255)
End If

If Me.Field4.Value = "" Then
Else
If Not IsNumeric(Field4.Value) Then
MsgBox "Please enter number only in VATIN.", vbCritical, "Type Numbers Only"
Field4.BackColor = RGB(255, 204, 204)
Field4.SetFocus
Exit Sub
Else
Field4.BackColor = RGB(191, 254, 255)
End If
End If

If Me.Field8.Value = "" Then
Else
If Not IsNumeric(Field8.Value) Then
MsgBox "Please enter number only in Payments Terms.", vbCritical, "Type Numbers Only"
Field8.BackColor = RGB(255, 204, 204)
Field8.SetFocus
Exit Sub
Else
Field8.BackColor = RGB(191, 254, 255)
End If
End If

With Sheet1
If IsEmpty(Sheet2.Range("C8").Value) Then
CustRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End If
.Cells(CustRow, "A").Value = Me.Field1.Value
.Cells(CustRow, "B").FillDown
.Cells(CustRow, "C").FillDown
.Cells(CustRow, "D").FillDown
.Cells(CustRow, "A").Locked = False

If IsEmpty(Sheet2.Range("C9").Value) Then
CustRow = .Cells(.Rows.Count, "K").End(xlUp).Row + 1
End If
.Cells(CustRow, "K").Value = Me.Field2.Value
.Cells(CustRow, "L").FillDown
.Cells(CustRow, "M").FillDown
.Cells(CustRow, "N").FillDown
.Cells(CustRow, "K").Locked = False

For CustCol = 14 To 20
Set CustomerFld = Me.Controls("Field" & CustCol - 12)
.Cells(CustRow, CustCol).Value = CustomerFld.Value
Next CustCol
.Cells(CustRow, "N").Locked = False
.Cells(CustRow, "O").Locked = False
.Cells(CustRow, "P").Locked = False
.Cells(CustRow, "Q").Locked = False
.Cells(CustRow, "R").Locked = False
.Cells(CustRow, "S").Locked = False

CustDetails.Hide

Sheet2.Range("C8").Value = Field1.Value
Sheet2.Range("C9").Value = Field2.Value
MsgBox "Customer is added to Client Lists Database", vbInformation, "Customer is Added to Database."
'Sheets("lists").Protect
End With
End Sub[/CODE]
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
kamranyd said:
Can we shorten these codes with any problems. So it can execute more quick.

VBA Code: 
Private Sub custnameonlysave_Click()
Dim CustRow As Long
Sheets("lists").Unprotect
Range("C8").MergeArea.ClearContents
    If Me.custnameonlytextBox.Value = Empty Then
        MsgBox "Please add customer name before saving", vbCritical, "Add Customer Name"
        Exit Sub
    End If
   
    With Sheet1
         If IsEmpty(Sheet2.Range("C8").Value) Then    'New Customer
         CustRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1  'First avail Row
    End If
       .Cells(CustRow, "A").Value = Me.custnameonlytextBox.Value
       .Cells(CustRow, "A").Locked = False
    End With
       
        CustNameOnly.Hide
        Sheet2.Range("C8").Value = custnameonlytextBox.Value    'Set Customer Name
        'Sheets("lists").Protect
End Sub
Quote ReplyReport
Sort by date Sort by votes
kamranyd
Board Regular
Sunday at 3:15 PM
Add bookmark
#2
kamranyd said:
these codes paste value at the last available row in column A, but i also want to copy above cell values which are in cell B, C, D columns down last row also?

VBA Code:
P
rivate Sub custnameonlysave_Click()
Dim CustRow As Long
Sheets("lists").Unprotect
Range("C8").MergeArea.ClearContents
    If Me.custnameonlytextBox.Value = Empty Then
        MsgBox "Please add customer name before saving", vbCritical, "Add Customer Name"
        Exit Sub
    End If
 
    With Sheet1
         If IsEmpty(Sheet2.Range("C8").Value) Then    'New Customer
         CustRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1  'First avail Row
    End If
       .Cells(CustRow, "A").Value = Me.custnameonlytextBox.Value
       .Cells(CustRow, "A").Locked = False
    End With
     
        CustNameOnly.Hide
        Sheet2.Range("C8").Value = custnameonlytextBox.Value    'Set Customer Name
        'Sheets("lists").Protect
End Sub
Click to expand...any help
Quote ReplyReport
Upvote
0
<div class="blockMessage blockMessage--warning blockMessage--iconic"> CAUTION: We see that you are trying to mark your own post as the solution. Please be sure that you are marking the post that actually contains the solution. </div>
Cubist
Cubist
Well-known Member
Monday at 5:44 PM
Add bookmark
#3
Not tested. Try this on a copy.
VBA Code:
Private Sub custnameonlysave_Click()
    Dim CustRow As Long
    Dim wsLists As Worksheet
    Dim wsData As Worksheet
   
    Set wsLists = ThisWorkbook.Sheets("lists")
    Set wsData = ThisWorkbook.Sheets("Sheet1")
   
    wsLists.Unprotect
   
    wsLists.Range("C8").MergeArea.ClearContents
   
    If Me.custnameonlytextBox.Value = Empty Then
        MsgBox "Please add customer name before saving", vbCritical, "Add Customer Name"
        Exit Sub
    End If
   
    With wsData
        If IsEmpty(wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Value) Then
            CustRow = 1
        Else
            CustRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
        End If
       
        .Cells(CustRow, "A").Value = Me.custnameonlytextBox.Value
        .Cells(CustRow, "A").Locked = False
       
        If CustRow > 1 Then
            .Range(.Cells(CustRow - 1, "B"), .Cells(CustRow - 1, "D")).Copy Destination:=.Range(.Cells(CustRow, "B"), .Cells(CustRow, "D"))
        End If
    End With
   
    CustNameOnly.Hide
   
    wsLists.Range("C8").Value = Me.custnameonlytextBox.Value
   
    ' wsLists.Protect
   
End Sub
 Like Quote ReplyReport
Upvote
0
Mark as solution
kamranyd
Board Regular
Yesterday at 3:04 PM
Add bookmark
#4
figured out how to do it, but seems codes got long, can it be shorten without any problem.

Private Sub SaveBtn_Click()

Dim CustRow As Long, CustCol As Long
Dim CustomerFld As Control

Range("C8").MergeArea.ClearContents
Range("C9").MergeArea.ClearContents

Sheets("lists").Unprotect

If Me.Field1.Value = Empty Then
MsgBox "Please add customer name before saving.", vbCritical, "Add Customer Name"
Field1.BackColor = RGB(255, 204, 204)
Field1.SetFocus
Exit Sub
Else
Field1.BackColor = RGB(191, 254, 255)
End If

If Me.Field2.Value = Empty Then
MsgBox "Please add company name before saving.", vbCritical, "Add Company Name"
Field2.BackColor = RGB(255, 204, 204)
Field2.SetFocus
Exit Sub
Else
Field2.BackColor = RGB(191, 254, 255)
End If

If Me.Field3.Value = Empty Then
MsgBox "Please add company three alphabet abbreviation before saving.", vbCritical, "Add Company Initial"
Field3.BackColor = RGB(255, 204, 204)
Field3.SetFocus
Exit Sub
Else
Field3.BackColor = RGB(191, 254, 255)
End If

If Me.Field4.Value = "" Then
Else
If Not IsNumeric(Field4.Value) Then
MsgBox "Please enter number only in VATIN.", vbCritical, "Type Numbers Only"
Field4.BackColor = RGB(255, 204, 204)
Field4.SetFocus
Exit Sub
Else
Field4.BackColor = RGB(191, 254, 255)
End If
End If

If Me.Field8.Value = "" Then
Else
If Not IsNumeric(Field8.Value) Then
MsgBox "Please enter number only in Payments Terms.", vbCritical, "Type Numbers Only"
Field8.BackColor = RGB(255, 204, 204)
Field8.SetFocus
Exit Sub
Else
Field8.BackColor = RGB(191, 254, 255)
End If
End If

With Sheet1
If IsEmpty(Sheet2.Range("C8").Value) Then
CustRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End If
.Cells(CustRow, "A").Value = Me.Field1.Value
.Cells(CustRow, "B").FillDown
.Cells(CustRow, "C").FillDown
.Cells(CustRow, "D").FillDown
.Cells(CustRow, "A").Locked = False

If IsEmpty(Sheet2.Range("C9").Value) Then
CustRow = .Cells(.Rows.Count, "K").End(xlUp).Row + 1
End If
.Cells(CustRow, "K").Value = Me.Field2.Value
.Cells(CustRow, "L").FillDown
.Cells(CustRow, "M").FillDown
.Cells(CustRow, "N").FillDown
.Cells(CustRow, "K").Locked = False

For CustCol = 14 To 20
Set CustomerFld = Me.Controls("Field" & CustCol - 12)
.Cells(CustRow, CustCol).Value = CustomerFld.Value
Next CustCol
.Cells(CustRow, "N").Locked = False
.Cells(CustRow, "O").Locked = False
.Cells(CustRow, "P").Locked = False
.Cells(CustRow, "Q").Locked = False
.Cells(CustRow, "R").Locked = False
.Cells(CustRow, "S").Locked = False

CustDetails.Hide

Sheet2.Range("C8").Value = Field1.Value
Sheet2.Range("C9").Value = Field2.Value
MsgBox "Customer is added to Client Lists Database", vbInformation, "Customer is Added to Database."
Sheets("lists").Protect
End With
End Sub
Quote ReplyReport
Upvote
0
<div class="blockMessage blockMessage--warning blockMessage--iconic"> CAUTION: We see that you are trying to mark your own post as the solution. Please be sure that you are marking the post that actually contains the solution. </div>
kamranyd
Board Regular
Yesterday at 3:05 PM
Add bookmark
#5
I figured out how to do it, but seems codes got long, can it be shorten without any problem.

Code:
Private Sub SaveBtn_Click()

Dim CustRow As Long, CustCol As Long
Dim CustomerFld As Control

Range("C8").MergeArea.ClearContents
Range("C9").MergeArea.ClearContents

Sheets("lists").Unprotect

If Me.Field1.Value = Empty Then
MsgBox "Please add customer name before saving.", vbCritical, "Add Customer Name"
Field1.BackColor = RGB(255, 204, 204)
Field1.SetFocus
Exit Sub
Else
Field1.BackColor = RGB(191, 254, 255)
End If

If Me.Field2.Value = Empty Then
MsgBox "Please add company name before saving.", vbCritical, "Add Company Name"
Field2.BackColor = RGB(255, 204, 204)
Field2.SetFocus
Exit Sub
Else
Field2.BackColor = RGB(191, 254, 255)
End If

If Me.Field3.Value = Empty Then
MsgBox "Please add company three alphabet abbreviation before saving.", vbCritical, "Add Company Initial"
Field3.BackColor = RGB(255, 204, 204)
Field3.SetFocus
Exit Sub
Else
Field3.BackColor = RGB(191, 254, 255)
End If

If Me.Field4.Value = "" Then
Else
If Not IsNumeric(Field4.Value) Then
MsgBox "Please enter number only in VATIN.", vbCritical, "Type Numbers Only"
Field4.BackColor = RGB(255, 204, 204)
Field4.SetFocus
Exit Sub
Else
Field4.BackColor = RGB(191, 254, 255)
End If
End If

If Me.Field8.Value = "" Then
Else
If Not IsNumeric(Field8.Value) Then
MsgBox "Please enter number only in Payments Terms.", vbCritical, "Type Numbers Only"
Field8.BackColor = RGB(255, 204, 204)
Field8.SetFocus
Exit Sub
Else
Field8.BackColor = RGB(191, 254, 255)
End If
End If

With Sheet1
If IsEmpty(Sheet2.Range("C8").Value) Then
CustRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End If
.Cells(CustRow, "A").Value = Me.Field1.Value
.Cells(CustRow, "B").FillDown
.Cells(CustRow, "C").FillDown
.Cells(CustRow, "D").FillDown
.Cells(CustRow, "A").Locked = False

If IsEmpty(Sheet2.Range("C9").Value) Then
CustRow = .Cells(.Rows.Count, "K").End(xlUp).Row + 1
End If
.Cells(CustRow, "K").Value = Me.Field2.Value
.Cells(CustRow, "L").FillDown
.Cells(CustRow, "M").FillDown
.Cells(CustRow, "N").FillDown
.Cells(CustRow, "K").Locked = False

For CustCol = 14 To 20
Set CustomerFld = Me.Controls("Field" & CustCol - 12)
.Cells(CustRow, CustCol).Value = CustomerFld.Value
Next CustCol
.Cells(CustRow, "N").Locked = False
.Cells(CustRow, "O").Locked = False
.Cells(CustRow, "P").Locked = False
.Cells(CustRow, "Q").Locked = False
.Cells(CustRow, "R").Locked = False
.Cells(CustRow, "S").Locked = False

CustDetails.Hide

Sheet2.Range("C8").Value = Field1.Value
Sheet2.Range("C9").Value = Field2.Value
MsgBox "Customer is added to Client Lists Database", vbInformation, "Customer is Added to Database."
'Sheets("lists").Protect
End With
End Sub[/CODE]
Click to expand...
oh, i also asked for codes to be shorten also, because its got way too long. how to ask for solution of this post i did. my intension was not to answers my own post.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question Question
how to copy above cell values down
Replies
5
Views
340
kamranyd
K
K
  • Question Question
vba code for unlocking cell after paste
Replies
1
Views
270
MikeVol
MikeVol
K
  • Question Question
User form for customer entry
Replies
2
Views
218
kamranyd
K
P
  • Solved
Textbox BackColor Problem
Replies
5
Views
508
rlv01
R
I
  • Question Question
Advice to remove old code for a new code
Replies
2
Views
197
ipbr21054
I

Forum statistics

Threads
1,223,704
Messages
6,173,984
Members
452,540
Latest member
haasro02

Share this page

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
Back
Top