ADVANCE VBA

SOME USEFUL VBA

learn how to use IsFileOpen or similar codes

   ---------------------------------------------------------

Sub MARK_NO_COPY()
'correction required program not ok
Dim ret
ret = IsWorkBookOpen("D:\6571 PETRO\hot case\inspection call 9-09-2019.xlsm")
If ret = True Then
    
   Dim answer As VbMsgBoxResult
answer = MsgBox("insp call file is not opened", vbYesNo + vbQuestion + vbDefaultButton2, "may I open ?")
If answer = vbYes Then
    'Workbooks.Open ("D:\6571 PETRO\hot case\inspection call 9-09-2019.xlsm")
    Windows("inspection call 9-09-2019.xlsm").Activate
    Range("B9").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("Copy Petrofac0001.xlsm").Activate
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("D4").Select
'Workbooks("inspection call 9-07-2019 (Repaired).xlsm").Close (True)
Else
    MsgBox " file is closed"
Exit Sub
End If
Else
    MsgBox " file NOT found"
End If
End Sub

   --------------------------------------------

Function IsFileOpen(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:    IsFileOpen = False

    Case 70:   IsFileOpen = True

    Case Else: Error ErrNo

    End Select

End Function

    ---------------------------------------------------------------------------------------------------------------

some other related VBA, can use in your way-

Sub Macro11()

    Dim X As Integer

         

        For X = 1 To Range("A10000").End(xlUp).Row

        Cells(X, 1).Select

        Selection.Copy

        Sheets("275mt_Area_list (1)").Select

        Range("D2").Select

        ActiveSheet.Paste

        Application.CUTCOPYMODE = False

        Range("A6:BF16979").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _

            Range("D1:L2"), Unique:=False

        Range("D6").Select

        ActiveCell.Select

        Range(Selection, Selection.End(xlDown)).Select

        Range("D6:L11076").Select

        Selection.Copy

        Sheets("Sheet2").Select

        Range("D1").Select

        Selection.End(xlDown).Select

        ActiveCell.Offset(1, 0).Range("A1").Select

        ActiveSheet.Paste

        ActiveWindow.SmallScroll Down:=-3

     Next

     

End Sub

    ------------------------------------------------------------------------------------------------

Sub Macro12()

   

   If Not IsFileOpen("D:\6571 PETROFAC\hot case\inspection call 9-09-2019.xlsm") Then

   Dim answer As VbMsgBoxResult

answer = MsgBox("insp call file is not opened", vbYesNo + vbQuestion + vbDefaultButton2, "may I open ?")

If answer = vbYes Then

    Call macro50

 Else

 End Sub

    ----------------------------------------------------------------------------------------------------------------- 

Sub macro50()

Workbooks.Open ("D:\6571 PETROFAC\hot case\inspection call 9-09-2019.xlsm")

 Windows("inspection call 9-09-2019.xlsm").Activate

    'Sheets("Workbooks.Open ("D:\6571 PETROFAC\hot case\inspection call 9-09-2019.xlsm")").Select

    Range("B9").Select

    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy

    Windows("Copy Petrofac0001.xlsm").Activate

    Sheets("Sheet2").Select

    Range("A1").Select

    ActiveSheet.Paste

    Range("D4").Select

End Sub

    -------------------------------------------------------------------------------------------------------------------

Sub MARK_NO_COPY()

'correction required program not ok

Dim ret

ret = IsWorkBookOpen("D:\6571 PETROFAC\hot case\inspection call 9-09-2019.xlsm")

If ret = True Then

    

   Dim answer As VbMsgBoxResult

answer = MsgBox("insp call file is not opened", vbYesNo + vbQuestion + vbDefaultButton2, "may I open ?")

If answer = vbYes Then

    'Workbooks.Open ("D:\6571 PETROFAC\hot case\inspection call 9-09-2019.xlsm")

    Windows("inspection call 9-09-2019.xlsm").Activate

    Range("B9").Select

    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy

    Windows("Copy Petrofac0001.xlsm").Activate

    Sheets("Sheet2").Select

    Range("A1").Select

    ActiveSheet.Paste

    Range("D4").Select

'Workbooks("inspection call 9-07-2019 (Repaired).xlsm").Close (True)

Else

    MsgBox " file is closed"

Exit Sub

End If

Else

    MsgBox " file NOT found"

End If

End Sub

   ------------------------------------------------------------------------------------------------------------------

Sub Macro4()

'Delete range d4 to copied from mecro 11

Dim answer As VbMsgBoxResult

answer = MsgBox("Are U sure ?", vbYesNo + vbQuestion + vbDefaultButton2, "Clear cells")

If answer = vbYes Then

    Sheets("Sheet2").Select

    Range("D1").Select

    ActiveCell.Offset(2, 0).Range("A1:I1").Select

    Range(Selection, Selection.End(xlDown)).Select

    Selection.Interior.Color = xlNone

    Selection.ClearContents

    'Call Macro9

         Range("A1:A1000").Select

         Selection.ClearContents

         Application.CUTCOPYMODE = False

    Range("D1").Select

Else

Exit Sub

End If

    MsgBox "DONE"

End Sub

    -------------------------------------------------------------------------------------------------------------------

Sub FIND_CATEGORY()

Application.ScreenUpdating = False

Dim xrowx As Long, xcolx As Long, tempA As Integer, tempB As Integer, tempC As Integer, condition As Integer, mystore As Long

condition = True

xrowx = 9

xcolx = 11

Sheets(115).Select

ActiveSheet.Cells(xrowx, xcolx).Select

Do While condition = True

    With Sheets(115)

        tempA = .Cells(xrowx, xcolx - 4).Value

        tempB = .Cells(xrowx, xcolx - 5).Value

        tempC = .Cells(xrowx, xcolx - 1).Value

        mystore = ((tempA / tempB) / (tempC / 1000))

    If mystore <= 30 Then

        ActiveCell.Value = "Light"

        ActiveCell.Interior.Color = 65535

    ElseIf mystore <= 60 Then

        ActiveCell.Value = "Medium"

        ActiveCell.Interior.ThemeColor = xlThemeColorAccent5

    Else

        ActiveCell.Value = "Heavy"

        ActiveCell.Interior.Color = 49407

    End If

        xrowx = xrowx + 1

        .Cells(xrowx, xcolx).Select

If .Cells(xrowx, xcolx - 1) = 0 Then

Range("K9").Select

Exit Do

End If

    End With

Loop

Application.ScreenUpdating = True

End Sub

    ------------------------------------------------------------------------------------------------------------------

Sub findnreplace()

Worksheets("Sheet1").Range("A2:A35").Select

Selection.Replace what:=Cells(i, 3).Value, replacement:=Cells(i, 4).Value, _

lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False

Next

Worksheets("Sheet1").Cells(1, 1).Select

End Sub

   -------------------------------------------------------------------------------------------------------------------------

Sub FileExists()

Dim fso As Scripting.FileSystemObject

Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FileExists("D:\6571 PETROFAC\hot case\inspection call 9-09-2019.xlsm") = True Then

MsgBox "The file is exists."

Else

MsgBox "The file isn't exists."

End If

End Sub

   ------------------------------------------------------------------------------------------------------------------

Sub PauseAmacroFor3sec()

Application.Wait (Now + TimeValue("0:00:05"))

 Application.SendKeys "{ENTER}"

End Sub

READ MORE
USEFUL VBA
ADD PASSWORD
PASSWORD BREAKER
TOP VBA
ALSO, READ
WELDING