Всем доброго времени суток!
Я новичок пытаюсь написать макрос для рабочий таблицы, но что то не выходит подскажите что не так?
Есть книга в ней таблицы все что нужно сделать подробно описано в презентации
а вот сам макрос:
Private Sub CommandButton1_Click()
'кнопка поиск в articles
Dim mystart
Dim myTarget As Range
Dim x!
mystart = Timer
If ActiveSheet.Name <> "Заказ товара с RD" Then
MsgBox "Данная операция работает только при активном листе ""Заказ товара с RD""", vbCritical, "LeroyMerlin"
Exit Sub
End If
With ThisWorkbook.Worksheets("Заказ товара с RD")
If .Range("B15") <> "" Then
x = .Cells(Rows.Count, 2).End(xlUp).Row
If x > 1 Then
Set myTarget = .Range("B15:B" & x)
' Application.EnableEvents = False
' .Unprotect "njdfhyfcrkflt"
ProsmotrArticles myTarget
' .Protect "njdfhyfcrkflt"
' Application.EnableEvents = True
End If
End If
End With
End Sub
Private Sub ProsmotrArticles(myTarget As Range)
Dim rngArt As Range, i As Byte
Application.Run "Module1.addCreateLink"
Set rstEMMin = New ADODB.Recordset
rstEMMin.CursorLocation = adUseClient
For Each rngArt In myTarget.Cells
stSQL = "SELECT * FROM Articles WHERE LM =" & rngArt.Value
rstEMMin.Open stSQL, cnnEMMin, adOpenStatic, adLockReadOnly
If rstEMMin.RecordCount > 0 Then
rngArt.Offset(0, 1) = rstEMMin.Fields(1)
rngArt.Offset(0, 2) = rstEMMin.Fields(2)
With ThisWorkbook.Worksheets("recep")
If .Range("D4") = "" Then
rngArt.Offset(-11, 2) = rstEMMin.Fields(6)
End If
End With
Else
MsgBox "Не найден артикул № " & rngArt.Value, vbCritical, "LeroyMerlin"
End If
rstEMMin.Close
Next
Set rstEMMin = Nothing
Application.Run "Module1.CloseLink"
End Sub
Private Sub CommandButton2_Click()
'добавить в таблицу
Dim mystart
Dim myTarget As Range
Dim x!
mystart = Timer
If ActiveSheet.Name <> "Заказ товара с RD" Then
MsgBox "Данная операция работает только при активном листе ""Заказ товара с RD""", vbCritical, "LeroyMerlin"
Exit Sub
End If
With ThisWorkbook.Worksheets("Заказ товара с RD")
If .Range("A2") <> "" Then
x = .Cells(Rows.Count, 1).End(xlUp).Row
If x > 1 Then
Set myTarget = .Range("A2:A" & x)
' Application.EnableEvents = False
' .Unprotect "njdfhyfcrkflt"
addArticles myTarget
' .Protect "njdfhyfcrkflt"
' Application.EnableEvents = True
End If
MsgBox Timer - mystart, vbInformation, "LeroyMerlin"
End If
End With
End Sub
Private Sub addArticles(myTarget As Range)
Dim rngArt As Range, i As Byte
Application.Run "Module1.addCreateLink"
Set rstEMMin = New ADODB.Recordset
rstEMMin.CursorLocation = adUseClient
For Each rngArt In myTarget.Cells
stSQL = "SELECT * FROM EMMinZapas4 WHERE LM =" & rngArt.Value
rstEMMin.Open stSQL, cnnEMMin, adOpenDynamic, adLockOptimistic
If rstEMMin.RecordCount > 0 Then
If MsgBox("артикул № " & rngArt.Value & "в базе существует" & Chr(13) & _
"Заменить минимальный запас?" & Chr(13) & _
rstEMMin.Fields(1) & " на " & rngArt.Offset(0, 7).Value, _
vbQuestion + vbYesNo, "LeroyMerlin") = vbYes Then
rstEMMin.Fields(1) = rngArt.Offset(0, 7).Value
rstEMMin.Update
End If
Else
rstEMMin.AddNew
rstEMMin.Fields(0) = rngArt.Value
rstEMMin.Fields(1) = rngArt.Offset(0, 7).Value
rstEMMin.Update
End If
rstEMMin.Close
Next
Set rstEMMin = Nothing
Application.Run "Module1.CloseLink"
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row > 1 Then
' Target.Worksheet.Unprotect "njdfhyfcrkflt"
Cells.Interior.ColorIndex = xlNone
Target.EntireRow.Interior.ColorIndex = 34
' Target.Worksheet.Protect "njdfhyfcrkflt"
End If
End Sub