Sub setupcodovww()
Application.ScreenUpdating = False
Dim x As Long, a()
Dim b As String

        If Not IsObject(sapplication) Then
        Set SapGuiAuto = GetObject("SAPGUI")
       Set sapplication = SapGuiAuto.GetScriptingEngine
        End If
        If Not IsObject(Connection) Then
        Set Connection = sapplication.Children(0)
         End If
         If Not IsObject(session) Then
        Set session = Connection.Children(0)
         End If
         If IsObject(WScript) Then
        WScript.Connection session, "on"
        WScript.Connection sapplication, "on"
End If
Range("C2:C100000").ClearContents
a = Range("B1", Range("A1").End(xlDown)).Value
For x = 2 To UBound(a)
If Len(CStr(a(x, 1))) = 0 Then Exit For


session.findById("wnd[0]/tbar[0]/okcd").Text = "/nmm01"
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]/usr/ctxtRMMG1-MATNR").Text = a(x, 1)
session.findById("wnd[0]/usr/ctxtRMMG1-MATNR").caretPosition = 8
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[1]/usr/ctxtRMMG1-WERKS").Text = "a709"
session.findById("wnd[1]/usr/ctxtRMMG1-LGORT").Text = a(x, 2)
session.findById("wnd[1]/usr/ctxtRMMG1-LGORT").caretPosition = 4
session.findById("wnd[1]").sendVKey 0

On Error GoTo 2
err_msg = session.findById("wnd[2]/usr/txtMESSTXT1").Text
If err_msg Like "Material already maintained for this" Then
session.findById("wnd[2]").Close
session.findById("wnd[1]/tbar[0]/btn[12]").press
Cells(x, 3) = "Material already exist with this location"
End If
GoTo 3
2:
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[1]/usr/btnSPOP-OPTION1").press
Cells(x, 3) = "Material created"
3:
Next

Application.ScreenUpdating = True
End Sub

Sub NoLockedClear()
Dim cl As Range
With ActiveSheet
    For Each cl In .UsedRange.Cells
        If Not cl.Locked Then cl.ClearContents
    Next
End With
End Sub

Sub NoLockedClear()
Dim cl As Range
With ActiveSheet
    For Each cl In .UsedRange.Cells
        If Not cl.Locked Then cl.MergeCells.ClearContents
    Next
End With
End Sub

Sub rtr()
curl = ActiveSheet.Name
nexts = Format(curl + 1, "00")
For x = 1 To 10
Status = Sheets(curl).Cells(x, 3)
If Status = "В процессе" Then
Sheets(nexts).Cells(x, 1) = Sheets(curl).Cells(x, 1)
Sheets(nexts).Cells(x, 2) = Sheets(curl).Cells(x, 2)
Sheets(nexts).Cells(x, 3) = Sheets(curl).Cells(x, 3)
Sheets(nexts).Cells(x, 4) = Sheets(curl).Cells(x, 4)
End If
Next
End Sub