Sub does not work using button but runs from VisualBasic window just fine

M

mysticmario

Active Member
Joined
Nov 10, 2021
Messages
323
Office Version
  1. 365
Platform
  1. 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


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
I have it assigned to a button, but the problem is that if I press the button macro prompts
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)"
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 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:
Sort by date Sort by votes
Yes that shoudl be the end result. I'll see if copy from your PC will solve the issue maybe my MS excel is somewhat broken
 
Upvote 0

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Nope it still skips to "done" i'm gonna try few things, maybe it's excel 365 problem it's not exactly the best working app as far as i can tell
 
Upvote 0
I think it is unfixable, I even tried to made a button that has this code to run macro internally.
VBA Code: 
Sub make_button()
Dim sheetName As String
Dim i As Integer
Dim sheetNumber As String
wbname = "'" & ActiveWorkbook.Name & "'" & "!"
sheetNumber = ThisWorkbook.ActiveSheet.CodeName & "."
Application.Run (wbname & sheetNumber & "kartarealizacji_Click")
End Sub
few more workarounds to go...
 
Upvote 0
Are you saying it doesn't run any of the code at all, other than the MsgBox line? So it doesn't even copy the worksheet at the start of that section?
 
Upvote 0
RoryA said:
Are you saying it doesn't run any of the code at all, other than the MsgBox line? So it doesn't even copy the worksheet at the start of that section?
Click to expand...
this is the result I get:
1666772844186.png
So it does run until this part:
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
at this point it shoudl start the "loop" and ask for additonal input:
VBA Code: 
'EXPORT DANYCH'
    Dim Rng As Range, cell As Range, lr As Long, i&, j&, mtr As Range, paint As Range
    lr = 10
    Sheets(ProjectSh).Range("D5") = Date

    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
But instead it goes straight to:
Call export_acc
where it executes only the:
VBA Code: 
MsgBox "Done!"
    Application.ScreenUpdating = 1

    Sheets("Karta Realizacji projektu").Activate
 
Upvote 0
Is there any code in the Worksheet_Activate or Worksheet_Deactivate events of any sheets?

Also, where are your variables like ProjectSh and LastSh declared?
 
Upvote 0
RoryA said:
Is there any code in the Worksheet_Activate or Worksheet_Deactivate events of any sheets?

Also, where are your variables like ProjectSh and LastSh declared?
Click to expand...
ProjectSh and LastSh are global variables they apply to entire workbook
and I do have activate and deactivate events, mainly for hiding sheets.
 
Upvote 0
Given that you are activating sheets in your code, you should probably be disabling events at the start of the code and then re-enabling them at the end.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Why vbYesNo doesnt exit sub when requested
Replies
4
Views
344
dmt32
D
M
  • Solved
exporting userform - doesn't work for other PC than mine
Replies
9
Views
411
Kyle123
Kyle123
M
  • Solved
Missing value, trying to find problem source in the code not written by me.
2
Replies
11
Views
643
mysticmario
M
M
  • Solved
Copy items from sheet1.range(X:X) to next empty cell in range located in Sheet2.
Replies
3
Views
471
kokano90
K
A
  • Question
sometimes show "Method 'Range' of object '_Worksheet' failed" error and maybe not error!!
Replies
0
Views
420
abdelfattah
A

Forum statistics

Threads
1,215,740
Messages
6,126,586
Members
449,319
Latest member
iaincmac

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top