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:

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Sort by date Sort by votes
Try to add workbook name in the beginning of macro. Or try to fiddle around with Macro Place.
1666691642963.png
 
Last edited by a moderator:
Upvote 0
Also your macro must be in a module like this:
1666694118443.png


If it is not in a module, if the macro is in a Sheet, you should specify the sheet name in Assign Macro window:
1666694312981.png
 
Upvote 0
Flashbond said:
Also your macro must be in a module like this:
View attachment 76974

If it is not in a module, if the macro is in a Sheet, you should specify the sheet name in Assign Macro window:
View attachment 76975
Click to expand...
I've been through all fo thta my macros are placed in a button via vba, the button itself is created in vba, because I need it to always run from the sheet on the module so here's my macro assigned.
1666696964200.png

correct workbook, correct sheet and correct name - in this case i'm usign anotehr macro to call this macro I figured that might help, but no.
Thsi is the only macro that cause mi trouble I have 3 oterh buttons who have macro assigned the same way and they work fine. Thsi has to be some inside bug in 365 or VBA in general
 
Upvote 0
Try to create a new module in VB screen and move your macro there. I have no other idea, sorry :(
 
Upvote 0
Unfortunately I cannot use modules in this file. The macro has to move with the copy of the sheet into a new workbook.
 
Upvote 0
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

Why would for loops run from VBA window and not from button, and I cannot seem to fidn any workaround.
If i put this code into module, cannot somehow copy this module to a newly created workbook automatically?
 
Upvote 0
Forget it, it does not work with module aswell. I also cannot use activeX buttons to keep co-authoring feature. Eh sad day
 
Upvote 0
Hello!

Button worked perfectly fine for me :) Should end result look like something like this?
1666707588283.png


In my computer Assign Macro window looks like this:
1666707659315.png

I will save the file and send it back to you. Maybe this will make it work for you, too!
 
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
638
mysticmario
M
M
  • Solved
Copy items from sheet1.range(X:X) to next empty cell in range located in Sheet2.
Replies
3
Views
469
kokano90
K
A
  • Question
sometimes show "Method 'Range' of object '_Worksheet' failed" error and maybe not error!!
Replies
0
Views
418
abdelfattah
A

Forum statistics

Threads
1,215,523
Messages
6,125,315
Members
449,218
Latest member
Excel Master

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