VBA Clean up

mrhonda

Board Regular
Joined
Feb 16, 2011
Messages
50
Hi guy's

I made a VBA code with the help of this forum, which works great thanks.
There is a lot of cell selecting going on etc.
So if it's not much to ask I'd like the experds here to through a glimps at it and maybe shorten it a bit? :)

thanks in advance

Code:
Private Sub Order_Click()
  Private Sub Order_Click()
    Dim rng1 As Range
    Set rng1 = Range("C1")
    
    If CBCustomer = "" Then
    MsgBox ("Selecteer de BV waarvoor je een klant wil aanmaken"), vbCritical, "Fout!"
    Exit Sub
    End If
    
    If CBName = "" Then
    MsgBox ("Selecteer een klant"), vbCritical, "Fout!"
    Exit Sub
    End If
    
    If TextBox1 = "" Then
    MsgBox ("Opdracht omschrijving invoeren"), vbCritical, "Fout!"
    Exit Sub
    End If
    
    If DateBox = "" Then
    MsgBox ("Start datum invoeren"), vbCritical, "Fout!"
    Exit Sub
    End If
    
    If DateBox2 = "" Then
    MsgBox ("Eind datum invoeren"), vbCritical, "Fout!"
    Exit Sub
    End If

    Application.ScreenUpdating = False
    Rows("6:6").Select
    Selection.Insert Shift:=xlDown
    Selection.Font.Bold = False
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "=TODAY()"
    Range("B6").Select
    If CBCustomer.Value = "Van Noorloos Casco Bouw BV" Then ActiveCell.FormulaR1C1 = "=CONCATENATE(""C-"",R1C3+1)"
    If CBCustomer.Value = "Fabistaal BV" Then ActiveCell.FormulaR1C1 = "=CONCATENATE(""F-"",R1C3+1)"
    If CBCustomer.Value = "Van Noorloos Waterjet Snijtechniek BV" Then ActiveCell.FormulaR1C1 = "=CONCATENATE(""W-"",R1C3+1)"
    Range("C6") = TextBox1.Value
    Range("D6") = CBName.Value
    Range("E6").Value = CDate(DateBox.Value)
    Range("F6").Select
    ActiveCell.FormulaR1C1 = _
        "=INT((RC[-1]-WEEKDAY(RC[-1])-DATE(YEAR(RC[-1]+4-WEEKDAY(RC[-1])),1,4))/7)+2"
    Range("G6").Value = CDate(DateBox2.Value)
    Range("H6").Select
    ActiveCell.FormulaR1C1 = _
        "=INT((RC[-1]-WEEKDAY(RC[-1])-DATE(YEAR(RC[-1]+4-WEEKDAY(RC[-1])),1,4))/7)+2"
    Range("I6").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-4]>R1C2,"""",SUM((R1C2-RC[-4])/(RC[-2]-RC[-4])))"
    Range("A6:B6").Copy
    Range("A6").Activate
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("C6").Select
    Range("Z1").Activate
    ActiveCell.Value = rng1 + 1
    ActiveCell.Copy
    Range("C1").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("Z1").ClearContents
    Range("A6:I6").Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.349986266670736
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A6").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Range("B6").Select
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
    End With
    Range("C6").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With
    Range("D6").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With
    Range("E6").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Range("F6").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Range("G6").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Range("H6").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Range("I6").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Range("A1").Select
    Unload NewOrder
    Application.ScreenUpdating = True
End Sub
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Try this:

Code:
Private Sub Order_Click()
    Dim rng1 As Range
    Set rng1 = Range("C1")
    
    If CBCustomer = "" Then
    MsgBox ("Selecteer de BV waarvoor je een klant wil aanmaken"), vbCritical, "Fout!"
    Exit Sub
    End If
    
    If CBName = "" Then
    MsgBox ("Selecteer een klant"), vbCritical, "Fout!"
    Exit Sub
    End If
    
    If TextBox1 = "" Then
    MsgBox ("Opdracht omschrijving invoeren"), vbCritical, "Fout!"
    Exit Sub
    End If
    
    If DateBox = "" Then
    MsgBox ("Start datum invoeren"), vbCritical, "Fout!"
    Exit Sub
    End If
    
    If DateBox2 = "" Then
    MsgBox ("Eind datum invoeren"), vbCritical, "Fout!"
    Exit Sub
    End If

    Application.ScreenUpdating = False
    With Rows("6:6")
        .EntireRow.Insert
        .Font.Bold = False
    End With
    
    Range("A6").FormulaR1C1 = "=TODAY()"
    With Range("B6")
        If CBCustomer.Value = "Van Noorloos Casco Bouw BV" Then
            .FormulaR1C1 = "=CONCATENATE(""C-"",R1C3+1)"
        ElseIf CBCustomer.Value = "Fabistaal BV" Then
            .FormulaR1C1 = "=CONCATENATE(""F-"",R1C3+1)"
        ElseIf CBCustomer.Value = "Van Noorloos Waterjet Snijtechniek BV" Then
            .FormulaR1C1 = "=CONCATENATE(""W-"",R1C3+1)"
        End If
    End With
    Range("C6") = TextBox1.Value
    Range("D6") = CBName.Value
    Range("E6").Value = CDate(DateBox.Value)
    Range("F6").FormulaR1C1 = _
        "=INT((RC[-1]-WEEKDAY(RC[-1])-DATE(YEAR(RC[-1]+4-WEEKDAY(RC[-1])),1,4))/7)+2"
    Range("G6").Value = CDate(DateBox2.Value)
    Range("H6").FormulaR1C1 = _
        "=INT((RC[-1]-WEEKDAY(RC[-1])-DATE(YEAR(RC[-1]+4-WEEKDAY(RC[-1])),1,4))/7)+2"
    Range("I6").FormulaR1C1 = "=IF(RC[-4]>R1C2,"""",SUM((R1C2-RC[-4])/(RC[-2]-RC[-4])))"
    
    Dim myCells As Range
    For Each myCells In Range("A6:B6")
        myCells.Value = myCells.Value
    Next
    
    Range("Z1").Value = rng1 + 1
    ActiveCell.Copy
    
    Range("C1").Value = Range("Z1").Value
    
    Range("Z1").ClearContents
    
    With Range("A6:I6")
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ThemeColor = 1
            .TintAndShade = -0.349986266670736
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
    
    With Union(Range("A6"), Range("E6:I6"))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    
    
    With Range("B6")
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
    End With
    
    With Range("C6:D6")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With
    Application.Goto Range("A1"), True
    Unload NewOrder
    Application.ScreenUpdating = True
End Sub
 
Upvote 0

Forum statistics

Threads
1,214,649
Messages
6,120,731
Members
448,987
Latest member
marion_davis

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