Is there a better way to structure this macro recording?

[Andries]

Hi There

Is there a better way to structure this macro recording. It seems to have some problems with the hide and unhide and the protect/unprotect part

Sub Macro6()
'
' Macro6 Macro
'

Sheets("Sheet3").Visible = True
Range("A1").Select
ActiveSheet.Unprotect
Range("A1").Select
ActiveCell.FormulaR1C1 = "TRUE"
Range("A1").Select
ActiveCell.FormulaR1C1 = "FALSE"
Range("A2").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets("Sheet3").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("REQUEST FORM").Select
Range("A7").Select
End Sub

 

[shg]

Maybe like this:

Sub Macro6()
    Dim wks         As Worksheet
 
    Set wks = Worksheets("Sheet3")
    
    With wks
        .Protect DrawingObjects:=True, _
                 Contents:=True, _
                 Scenarios:=True, _
                 UserInterfaceOnly:=True
        .Range("A1").Value = False
    End With
End Sub

 

[njimack]

Something like this:

Sub Macro6()

With Sheets("Sheet3")
.Unprotect
.Range("A1")= "TRUE"
.Range("A2")= "FALSE"
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
End Sub

 

[Andries]

Hi

Thank you very much shg4421 & njimack. It is working perfectly.

How about this one....it is working but I think it can do better



Sub Macro2()
Dim cell As Range

Sheets("Request Form").Select
Sheets("Request Form").Range("A10:J10000").Select
Selection.Clear

Sheets("MASTER TIME TABLE").Range("A6:J1042").AdvancedFilter Action:= _
xlFilterCopy, CriteriaRange:=Range("'REQUEST FORM'!Criteria"), CopyToRange _
:=Range("A10"), Unique:=False

Sheets("REQUEST FORM").Select
Range("A10:J10000").Select
ActiveWorkbook.Worksheets("REQUEST FORM").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("REQUEST FORM").Sort.SortFields.Add Key:=Range( _
"G11:G10000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("REQUEST FORM").Sort.SortFields.Add Key:=Range( _
"H11:H10000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("REQUEST FORM").Sort.SortFields.Add Key:=Range( _
"E11:E10000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("REQUEST FORM").Sort
.SetRange Range("A10:J10000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


Set cell = Range("j11")
Do While Not IsEmpty(cell)
If cell > 1 Then
Range(cell.Offset(1, 0), cell.Offset(cell.Value - 1, 0)).EntireRow.Insert
Range(cell, cell.Offset(cell.Value - 1, 1)).EntireRow.FillDown
End If
Set cell = cell.Offset(cell.Value, 0)
Loop


Sheets("Request Form").Range("A11:J10000").copy Destination:=Sheets("data2").Range("F2")
Sheets("Request Form").Select
Range("a7").Select
End Sub

Sub Clearsht()
Sheets("Request Form").Select
Sheets("Request Form").Range("A10:J10000").Select
Selection.Clear
Range("a7").Select
End Sub

 

[shg]

Maybe like this:

Sub Macro2()
    Dim cell        As Range
    Dim wks         As Worksheet
 
    Set wks = Worksheets("Request Form")
 
    With wks
        .Range("A10:J10000").Clear
 
        Worksheets("MASTER TIME TABLE").Range("A6:J1042").AdvancedFilter _
                Action:=xlFilterCopy, _
                CriteriaRange:=.Range("Criteria"), _
                CopyToRange:=.Range("A10"), _
                Unique:=False
 
        With .Sort
            .SortFields.Clear
            .SetRange Range("A10:J10000")
            .SortFields.Add Key:=Range("G10"), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending, _
                            DataOption:=xlSortNormal
            .SortFields.Add Key:=Range("H10"), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending, _
                            DataOption:=xlSortNormal
            .SortFields.Add Key:=Range("E10"), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlDescending, _
                            DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .Apply
        End With
 
        Set cell = .Range("J11")
        Do While Not IsEmpty(cell.Value)
            If cell.Value > 1 Then
                Range(cell.Offset(1), cell.Offset(cell.Value - 1)).EntireRow.Insert
                Range(cell, cell.Offset(cell.Value - 1, 1)).EntireRow.FillDown
            End If
            Set cell = cell.Offset(cell.Value)
        Loop
 
        .Range("A11:J10000").Copy Destination:=Worksheets("Data2").Range("F2")
        Application.Goto .Range("A7")
    End With
End Sub

 

[Andries]

Once again working like a charm. Thanks

 

[Andries]

Hi

Ok now I have added this code:
but it does not work properly because it is suppose to loop through. When I hit the process button the first time around it should run this code in cloumn B and the values should stay there, and when I hit the process button again it should do exactly the same code as in column B but only in column C and so on. Each column has a date heading and based on what the date is on "data2" it should run the code only in that specific column

Sheets("ALL").Select
Range("b49").Select
ActiveCell.FormulaR1C1 = _ "=IFERROR(IF(AND(R47C2=data2!R1C8,data2!R1C9=1)*TRUE,VLOOKUP(RC1,data2!R2C1:R4000C15,2,0),""""),""NR"")"
Sheets("ALL").Range("b49").copy Destination:=Range("b50:b105,b108:b126")
Range("B49:B105").Select
Selection.copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B108:B126").Select
Selection.copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False



Range("C49").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(IF(AND(R47C2=data2!R1C8,data2!R1C9=2)*TRUE,VLOOKUP(RC1,data2!R2C1:R4000C15,2,0),""""),""NR"")"
Sheets("ALL").Range("c49").copy Destination:=Range("c50:c105,c108:c126")
Range("c49:c105").Select
Selection.copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("c108:c126").Select
Selection.copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False