mysticmario
Active Member
- Joined
- Nov 10, 2021
- Messages
- 323
- Office Version
- 365
- Platform
- Windows
I have this macro that populates my materials sheet based on the priced products I use a multifunctional macro for it
This macro should loop through wide variety of ranges and either grab the required data or ask for input to specify additional propeties of the material
here's how it looks
I have it assigned to a button, but the problem is that if I press the button macro prompts
and if I press "yes" i does not execute the code that should be executed fi the response is yes it skips entire code up to this point
If i press "NO" it executes the the "Else" condition:
But if I click "assign macro..." and "edit" on the button itself and run the code frow VisualBasic window (F5 or play button) it works perfectly fine
I tried to copy and paste the code to new sub and then apply it to the button but that didnt help aswell.
Can anyone help me out with this one?
This macro should loop through wide variety of ranges and either grab the required data or ask for input to specify additional propeties of the material
here's how it looks
VBA Code:
Sub kartarealizacji_Click()
Dim Response As VbMsgBoxResult
Sheets("SZABLON_SZAFA").Unprotect
Sheets("KARTA REALIZACJI").Visible = True
Const strPrompt As String = "Czy projekt jest juz rozpoczęty w systemie?" & vbCrLf & _
"(Aby poprawnie wygenerować Karte Realizacji, projekt musi być OTWARTY w systemie " & _
"(ArtProInfo v1.5/LISTA OTWARTYCH PROJEKTÓW)"
Response = MsgBox(strPrompt, vbYesNo)
If Response = vbYes Then
LastSh = ActiveSheet.Name
Sheets("KARTA REALIZACJI").Visible = xlSheetVisible
Sheets("KARTA REALIZACJI").Copy After:=Sheets(Sheets.Count)
Sheets("KARTA REALIZACJI").Visible = xlSheetVeryHidden
ActiveSheet.Name = "Karta Realizacji projektu"
ProjectSh = ActiveSheet.Name
Sheets(LastSh).Activate
'EXPORT DANYCH'
Dim Rng As Range, cell As Range, lr As Long, i&, j&, mtr As Range, paint As Range
Sheets(ProjectSh).Range("D5") = Date
lr = 10
Set paint = ActiveSheet.Range("H43,H44,H76,H77, H78, H109,H110,H111,H142,H143,H175,H176")
Set mtr = ActiveSheet.Range("E19, E52, E85, E118, E151")
Set Rng = ActiveSheet.Range("H195:H273")
For Each cell In mtr
If Not IsEmpty(cell) And cell.Value <> 0 Then
lr = lr + 1
Sheets(ProjectSh).Cells(lr, "B").Value = ("Płyta " & cell.Value)
Sheets(ProjectSh).Cells(lr, "C").Value = cell.Offset(20, 1).Value & "m2"
lr = lr + 1
If cell.Offset(20, 4).Value > 0 Then
Sheets(ProjectSh).Cells(lr, "B").Value = ("Obrzeże " & cell.Value)
Sheets(ProjectSh).Cells(lr, "C").Value = cell.Offset(20, 4).Value & "mb"
Else:
lr = lr - 1
GoTo nextcell
End If
End If
nextcell: Next cell
lr = lr + 1
For Each cell In paint
If Not IsEmpty(cell) And cell.Value <> 0 Then
Dim lakier As String
lakier = InputBox("Dla pozycji: " & "" & cell.Offset(, -4).Value & " - " & cell.Value & "m2" & " " & "jakiego lakieru?", "RODZAJ, TYP, DOSTAWCA (PRZYKŁAD: BEZBARWNY HD CRYL - MARIANUS)")
Sheets(ProjectSh).Cells(lr, "B").Value = ("Lakier: " & lakier)
Sheets(ProjectSh).Cells(lr, "C").Value = cell.Value & "m2"
lr = lr + 1
Else:
GoTo nextitem
End If
nextitem: Next cell
lr = lr + 1
Call export_acc
Else
MsgBox "Wprowadź projekt do systemu": Exit Sub
End If
Sheets("SZABLON_SZAFA").Protect
End Sub
Private Sub export_acc()
Sheets("SZABLON_SZAFA").Unprotect
Dim Rng As Range, cell As Range, lr As Long, i&, j&, S, T%, X
Dim ws As Worksheet
Application.ScreenUpdating = 0
Set ws = Sheets(ProjectSh)
Set Rng = Sheets(LastSh).Range("H195:H273")
S = Array("B", "K", "T")
With ws
T = Application.WorksheetFunction.CountA(.Range("B11:B30,K11:K30,T11:T30"))
If T >= 60 Then MsgBox "Full line.Please check data": Exit Sub
If T > 0 Then
X = Int(T / 20)
lr = .Cells(30, S(X)).End(3).Row
Else
lr = 10
X = 0
End If
End With
For Each cell In Rng
If Not IsEmpty(cell) And cell.Value <> 0 Then
lr = lr + 1
If lr < 31 Then
If X <= 2 Then
ws.Cells(lr, S(X)).Value = Sheets(LastSh).Range("D" & cell.Row).Value & " " & Sheets(LastSh).Range("E" & cell.Row).Value
ws.Cells(lr, S(X)).Offset(, 1).Value = cell.Value & cell.Offset(0, 1).Value
Else
MsgBox "Check the return area": Exit Sub
End If
Else
X = X + 1
lr = lr - 20
If X <= 2 Then
ws.Cells(lr, S(X)).Value = Sheets(LastSh).Range("D" & cell.Row).Value & " " & Sheets(LastSh).Range("E" & cell.Row).Value
ws.Cells(lr, S(X)).Offset(, 1).Value = cell.Value & cell.Offset(0, 1).Value
Else
MsgBox "Check the return area": Exit Sub
End If
End If
End If
Next cell
Application.ScreenUpdating = 1
MsgBox "Done"
Sheets("Karta Realizacji projektu").Activate
'ActiveSheet.Range("C3:H3").Select
'With Selection.Validation
'.Delete
'.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, operator:= _
'xlBetween, Formula1:="='OTWARTE PROJEKTY'!$B$3:$B$70"
'.IgnoreBlank = True
'.InCellDropdown = True
'.InputTitle = ""
'.ErrorTitle = ""
'.InputMessage = ""
'.ErrorMessage = ""
'.ShowInput = True
'.ShowError = True
'End With
Sheets("SZABLON_SZAFA").Protect
End Sub
VBA Code:
Const strPrompt As String = "Czy projekt jest juz rozpoczęty w systemie?" & vbCrLf & _
"(Aby poprawnie wygenerować Karte Realizacji, projekt musi być OTWARTY w systemie " & _
"(ArtProInfo v1.5/LISTA OTWARTYCH PROJEKTÓW)"
MsgBox "Done"
If i press "NO" it executes the the "Else" condition:
Else
MsgBox "Wprowadź projekt do systemu": Exit Sub
But if I click "assign macro..." and "edit" on the button itself and run the code frow VisualBasic window (F5 or play button) it works perfectly fine
I tried to copy and paste the code to new sub and then apply it to the button but that didnt help aswell.
Can anyone help me out with this one?
Last edited by a moderator: