Quantcast
Channel: Excel Help Forum - Excel Programming / VBA / Macros
Viewing all 49833 articles
Browse latest View live
↧

Dynamic Sumif Arrays

April 7, 2020, 10:43 am
$
0
0
I receive data (highlighted in yellow in the attached) in various positions from each reporting file. I need to write a VBA function that will let me dynamically sum the data based on where the columns line up in that particular report. The output (orange highlight) that I have envisioned in my head would allow the user to input (1) the SUMIF criteria column (2) the SUMIF sum column. Thoughts? Thanks in advance for your help.
Attached Files
↧
Search

Verify Sheet exist before copying

April 7, 2020, 10:49 am
$
0
0
I am creating a workbook for work that will contain customer data. Each sheet will be named for the customer number. On my main page I have an ActiveX command button that runs the sub shown below. Once I click on the button it will ask me to input the customer number I want to create, then it makes the Starter Sheet visible, makes a copy of Starter Sheet it and renames it to the customer number that I entered and then hides the starter sheet.

It works well except for a little flaw. The flaw it has is if the sheet already exists then the code copies the starter sheet and renames it Starter Sheet(X). I need help with making the code. If sheet exist then prompt sheet exist but don't allow the sheet to be created.

The Starter Sheet is a formatted sheet that I plan to use each customer. It has code on the sheet that takes the sheet name an places it on a cell on said sheet.

I also would like to restrict the data being entered to 5 digits only (00001 - 99999)

Any help and suggestions would be greatly appreciated.

AmosA


Code I am using.

Code:
Private Sub CommandButton5_Click()

    'Sub CopySheetAndRename()
    Dim newName As String
       
    On Error Resume Next
    newName = InputBox("Enter 5 Digit Customer Number")
 
    If newName <> "" Then
        Worksheets("Starter sheet").Visible = True
        Application.ActiveWorkbook.Sheets("Starter Sheet").Copy after:=Worksheets(Sheets.Count)
               
        On Error Resume Next
        ActiveSheet.Name = newName
       
               
    End If
   
        Worksheets("Starter Sheet").Visible = False
       
End Sub
↧
↧

Doubleclick on cell in range and open textbox or other cell in help column

April 7, 2020, 10:55 am
$
0
0
Hi. I have tried look at this and cant really find out the best way to do it.

I have a part of a sheet with many formulas, and i cant really change that to example insert extra column, it will give a huge work.
In Sheet2 fram range B6 to B370 i would need to be able to put separate text which refer to cell B6. I can t mix the text which is there now .
My idea was maybe there can be a way to double click on cell B6 and then open a text box which i can write in and copy from.
If like that it have to be a specific text box for each cell.
Or other way could be to double click cell B6 and example open a help column and cell AM6 and here write the text. And maybe have text boxes in this help column.
So it was like double click B6 go to AM6, B7 go to AM7, B8 go to AM8, All the way down to B370 and AM370

I am not sure which and how it can be done, maybe other ways are better, The only thing is i cant insert a column.

Please have a look i have attached a test sheet you can try and play with .
Thanks in advance
Sincerely
Abjac
Attached Files
↧

VBA Advanced filter questions

April 7, 2020, 11:02 am
$
0
0
I used the following code frome Advanced Filter And Or project;



Code:
Sub Rectangle4_Click()

'Dim variables

Dim Num As Range

Dim Dt As Worksheet, Ft As Worksheet

'set variables

Set Num = Sheet1.Range("G2")

Set Dt = Sheet2

Set Ft = Sheet1

'if no dates then change criteria

If Ft.Range("C6").Value = "" Or Ft.Range("D6").Value = "" Then

Dt.Range("D4").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _

CriteriaRange:=Ft.Range("GC5:GD" & Num), CopyToRange:=Ft.Range("C14:K14"), Unique:=False

'if filtering between dates then change criteria

Else

Dt.Range("D4").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _

CriteriaRange:=Ft.Range("GA5:GD" & Num), CopyToRange:=Ft.Range("C14:K14"), Unique:=False

End If

 

End Sub


You may notice that I moved the Criteria box over to GA. This code works great.



Line Data Smart form spreadsheet has data from A to FA. When the options for this are added to the original choices, there are choices from GA to LX. The Data still comes from Sheet2, however I have the Filter on Sheet9.

I tried the code below and ended up with a worksheet error. Any chance you can help out? The code looks identical to me.



Code:
Sub Rectangle4_Click()

'Dim variables

Dim Num As Range

Dim Dt As Worksheet, Ft As Worksheet

'set variables

Set Num = Sheet1.Range("G2")

Set Dt = Sheet2

Set Ft = Sheet9

'if no dates then change criteria

If Ft.Range("C6").Value = "" Or Ft.Range("D6").Value = "" Then

Dt.Range("O1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _

CriteriaRange:=Ft.Range("GC5:GD" & Num), CopyToRange:=Ft.Range("C14:LX14"), Unique:=False

'if filtering between dates then change criteria

Else

Dt.Range("O1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _

CriteriaRange:=Ft.Range("GA5:GD" & Num), CopyToRange:=Ft.Range("C14:LX14"), Unique:=False

End If

 

End Sub
↧

VBA Loop Until cell = integer

April 7, 2020, 11:08 am
$
0
0
Hello All,

First time posting here but I am stuck. Normally I can tie together parts from amazing responses here to figure it out but not this time. What I want to accomplish it to reduce a cell value by 1 until an equation equals a full integer. Replacing C1 below with A1 -1 until C1 is an integer.

A1=500
B1=15
C1= cell starting at 500 (or A1) reducing by 1 until D1 = integer
D1 = ((A1/2)/B1)*100)

492 is what C1 should say and D1 should be 1640 if the loop runs correctly
↧
↧

Need to find rows of five columns that contain any three of twelve values

April 7, 2020, 11:16 am
$
0
0
Apologies if this has been covered elsewhere, but can't find anything on here.

Cols B - F contain one hundred and fifty rows with numbers in each cell between 1 - 39, which cannot be 're-sorted' into horizontal order.

Col J contains twelve numbers between 1 - 39 which cannot be "re-sorted" into ascending order.

Need code to find the records that contain ANY three of the twelve numbers.

Appreciate it's customary to attach the "what I have tried" Code, but can't even think how to start this?

All suggestions and solutions welcome as ever

Ochimus
Attached Files
↧

Trying to send XML with a time out

April 7, 2020, 11:26 am
$
0
0
Trying to send XML (to SAP) with a time out

I have something like this

Code:
Dim Resp As New MSXML2.DOMDocument60

    Set Req = CreateObject("MSXML2.XMLHTTP")
    Set Resp = CreateObject("MSXML2.DOMDocument.6.0")
    Req.Open "Post", sapURL, False
    Req.setRequestHeader "Content-Type", "text/xml"
    Req.send (sEnv)
and I see online that I should be able to do this

https://stackoverflow.com/questions/...eout-using-asp

Code:
    Dim Resp As New MSXML2.DOMDocument60
   
    Set Req = CreateObject("MSXML2.ServerXMLHTTP")
    Set Resp = CreateObject("MSXML2.DOMDocument.6.0")
    Req.setTimeouts 600000, 600000, 15000, 15000
    Req.Open "Post", sapURL, False
    Req.setRequestHeader "Content-Type", "text/xml"
    Req.send (sEnv)
and another one above that using "waitforresponse"

however i get error 401 (which i think is unauthorized?) and seems to result from "MSXML2.XMLHTTP" to "MSXML2.ServerXMLHTTP"
I guess that means something on that other side isn't set up to handle this method? (I will discuss with them if needed)

Is anyone familiar with this or another method and what I could do to get a time out working?
↧

Checkbox in UserForm to hide/unhide columns.

April 7, 2020, 11:52 am
$
0
0
Hello,


If anyone could advice how to hide/unhide columns using checkboxes in userform, so that state of checkbox remains if it was true or false from last time userform was called.

Code:
Private Sub SettingsForm_Initialize()

    If Cells("H:V").EntireColumn.Hidden = True Then
    CheckBox1.Value = True
    End If

End Sub

Private Sub CheckBox1_Click()

    Columns("H:V").EntireColumn.Hidden = CheckBox1.Value

End Sub
This is my current code and every time when I reopen userform checkbox is reset to false.


Thank you!
↧
Search

Catastrophic Failure Error

April 7, 2020, 12:31 pm
↧
↧

Join function with exclude criteria

April 7, 2020, 12:47 pm
$
0
0
Hi all,
I have a project in which I created a macros that sends email when a command button is pressed. I use the join function to concatenate a range with emails with a separator of ";". I did not add any code in this thread because my issue is pretty straightforward. On a separate cell I have the email of the user that opens the excel project. So each user that opens the project and triggers the command button an Outlook object is created with the recipients the range I have using the join function. However the thing is that I want to take that range with emails and exclude the one of the current user. Is there any way to do that as simple as possible, maybe an extension on the already join function I have?
Thank you
↧

Outlook an email with .xls attachment, download and open Workbook

April 7, 2020, 12:48 pm
$
0
0
Hello all,

I receive an email everyday from the same sender in my general inbox "Inbox" with a .xls attachment. The file is always called the same and the email is always the same just with new data each day. Is there a way to Activate this workbook from a VBA macro, i.e. click macro --> go into outlook --> search for email on current day --> download spreadsheet --> activate it

The email is produced systematically and is always has Subject "Open Report" and always sent from same sender zq12734@gmail.com

Can someone pls guide me on the right path.

Many thanks for your time.

lougs7
↧

Save files as pdf in a folder based on date

April 7, 2020, 12:53 pm
$
0
0
I need to create a macro that saves the file as a PDF in Dropbox (P:\) and then put in a folder that is based on date of the order. Example would be P:\AM\Orders\040720\Filename.pdf.

The file name is determined from the value in cell B4. The date of the order is in cell H4. There could be many orders in the same day so the first order of the day would create the "Date" folder in Dropbox. Each subsequent order of the day would have to confirm if the folder already exists. If TRUE save to the existing folder, and if FALSE create a folder for the day and put the file in it.

Below is what I have already working but need to add the date variable. Please let me know if you need any further information.


Code:
Sub AM_Orders()
'
' Save Order to Dropbox Macro
''
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="P:\AM\Orders\" + Range("B4").Value _
    , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
    :=False, OpenAfterPublish:=False

       
End Sub
↧

Password character in InputBox

April 7, 2020, 1:18 pm
$
0
0
Hello everyone, I am trying to get user's passwords in a way so that they can enter it securely. One way is to simply create a form add a lable, add a textbox, and then a button, and then set the 'PasswordChar' property to "*", like such.
Programming.png

BUT, the problem, or lets say preferred way here is that I want all this to be in a single module, not two or three parts, just so it would make copying and pasting it later on easy, as easy as copying the whole project in a single go.

At first I decided to construct the whole form, or input form, programmatically in the module itself, the problem with that solution is that it requires that some security settings should be changed so that it allows using VBProject to manipulate project objects from VB, which is not enjoyable, finally I found this solution on mrexcel.com:

Code:
Option Explicit
'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'http://www.danielklann.com/
'March 2003
'// Kindly permitted to be amended
'// Amended by Ivan F Moala
'// http://www.xcelfiles.com
'// April 2003
'// Works for Xl2000+ due the AddressOf Operator
'////////////////////////////////////////////////////////////////////

'API functions to be used
Private Declare Function CallNextHookEx _
    Lib "user32" ( _
    ByVal hHook As Long, _
    ByVal ncode As Long, _
    ByVal wParam As Long, _
    lParam As Any) _
As Long
Private Declare Function GetModuleHandle _
    Lib "kernel32" _
    Alias "GetModuleHandleA" ( _
    ByVal lpModuleName As String) _
As Long
Private Declare Function SetWindowsHookEx _
    Lib "user32" _
    Alias "SetWindowsHookExA" ( _
    ByVal idHook As Long, _
    ByVal lpfn As Long, _
    ByVal hmod As Long, _
    ByVal dwThreadId As Long) _
As Long
Private Declare Function UnhookWindowsHookEx _
    Lib "user32" ( _
    ByVal hHook As Long) _
As Long
Private Declare Function SendDlgItemMessage _
    Lib "user32" Alias "SendDlgItemMessageA" ( _
    ByVal hDlg As Long, _
    ByVal nIDDlgItem As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) _
As Long
Private Declare Function GetClassName _
    Lib "user32" _
    Alias "GetClassNameA" ( _
    ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) _
As Long
Private Declare Function GetCurrentThreadId _
    Lib "kernel32" () _
As Long
'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Private hHook As Long
Public Function NewProc(ByVal lngCode As Long, _
                        ByVal wParam As Long, _
                        ByVal lParam As Long) As Long
Dim RetVal
Dim strClassName As String, lngBuffer As Long
If lngCode < HC_ACTION Then
    NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
    Exit Function
End If
strClassName = String$(256, " ")
lngBuffer = 255
If lngCode = HCBT_ACTIVATE Then    'A window has been activated
    RetVal = GetClassName(wParam, strClassName, lngBuffer)
    If Left$(strClassName, RetVal) = "#32770" Then  'Class name of the Inputbox
        'This changes the edit control so that it display the password character *.
        'You can change the Asc("*") as you please.
        SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
    End If
End If
   
'This line will ensure that any other hooks that may be in place are
'called correctly.
CallNextHookEx hHook, lngCode, wParam, lParam
End Function
'// Make it public = avail to ALL Modules
'// Lets simulate the VBA Input Function
Public Function InputBoxDK(Prompt As String, Optional Title As String, _
            Optional Default As String, _
            Optional Xpos As Long, _
            Optional Ypos As Long, _
            Optional Helpfile As String, _
            Optional Context As Long) As String
   
Dim lngModHwnd As Long, lngThreadID As Long
   
'// Lets handle any Errors JIC! due to HookProc> App hang!
On Error GoTo ExitProperly
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
   
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
If Xpos Then
    InputBoxDK = InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context)
Else
    InputBoxDK = InputBox(Prompt, Title, Default, , , Helpfile, Context)
End If
ExitProperly:
UnhookWindowsHookEx hHook
End Function
Sub TestDKInputBox()
Dim x
x = InputBoxDK("Type your password here.", "Password Required")
If x = "" Then End
If x <> "yourpassword" Then
    MsgBox "You didn't enter a correct password."
    End
End If
MsgBox "Welcome Creator!", vbExclamation
   
End Sub
Now the problem with this code is that in newer versions of office, on 64bit machines it says that it needs 'PtrSafe' to declare windows API functions and subs. Now when I use a

Code:
#IF VBA7 then
Decalre PtrSafe sub...
#Else
Declare sub...
#EndIf
According to https://docs.microsoft.com/en-us/off...trsafe-keyword

so the declration section has now become like this:

Code:
#If VBA7 Then
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
#Else
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
#End If
I am getting "Compile Error: Type Mismatch" error, when this line executes:
Code:
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
here is a sample workbook with the problematic section: Pass_Inbox.xlsm

Now I am stuck and I don't know what to do. This code was just running fine on my somewhat older office, on my laptop, but when I brought it to company machine with office 2016 64bit, now it is not working because of type mismatch error. I don't know what to do, please help me with this pain in the neck problem I have exhausted all things I could think of and the reason why I am here. This is my ultimate final resort.
↧
↧

Separate output file for each teacher

April 7, 2020, 1:25 pm
$
0
0
Hi,

I have a big file...…...a subset of this file is enclosed.

In this file I have 3 cols: Teacher, Subject, and Amt

What I want to do is create an output file for each Teacher. In this output file will be the 3 cols Teacher, Subject, and Amt of data.

I was thinking of using a dictionary to do this but again not sure how. Thoughts?
Attached Files
↧

VBA Outlook - send by person rather than subject

April 7, 2020, 1:25 pm
$
0
0
Evening All

I currently use VBA code to send a chase e-mail for every project, and now I would like to send one e-mail per Project Manager with project names in bullet points. I would like to use my existing code template but tweak the wording as per the below.

I’m not able to post the code due to a firewall error but it is in the sheet.

Cheers!

Subject: Action Required - WE (LW2)

Hi (Project Manager Name)

You are listed in Project Builder as the Project Manager for the below projects. Please complete the following overdue actions as soon as possible:

INITIAL SUBMISSION
  • Project Name 1
  • Project Name 2
  • Project Name 3 etc...


DATA COLLECTION
  • Project Name 1
  • Project Name 2
  • Project Name 3 etc...

Kind regards

Delivery Team
Attached Files
↧
Search

Vlookup and paste from multiple sheets

April 7, 2020, 1:39 pm
$
0
0
Hi All,

Hoping you all can help. I have list that is on sheet 1 (customer names), which i'm trying to lookup the data on sheet 2 and 3 and paste the whole column (transposed) onto a new sheet. One nuance that i have is the customer list will vary and the customer details on sheet 2 and 3 will vary in length as well as the number of sheets (so for example there will be more sheets with the customer data on that i would be looking to collate together). Hoping you can help


Sheet 1
Customer 1
Customer 2
Customer 3

Sheet 2
Customer 1 Customer 2 Cusstomer 3
1 2 3
3 4 5
4 5 7

Sheet 3
Customer 1 Customer 2 Cusstomer 3
1 2 5
3 4 3
4 5 8
↧

Error duplicating a range between workbooks

April 7, 2020, 2:57 pm
$
0
0
I have the following code for a Userform button:

Code:
Private Sub btnPending_Click()
Dim pLR As Long
Dim ws As Worksheet

Stop
Set ws = ThisWorkbook.Sheets("Pending")
ws.Activate
pLR = ws.Cells(1, 1).End(xlDown).Row
Acct = ThisWorkbook.BuiltinDocumentProperties("Category")
ImprtFile = ThisWorkbook.BuiltinDocumentProperties("Format")
tradeRow = ThisWorkbook.BuiltinDocumentProperties("Manager")

Stop
PendingForm.Hide
'Next line throws a 1004 error**********************************************************
ws.Range(Cells(pLR + 1, 1), Cells(pLR + 1, 12)) = Workbooks(ImprtFile & ".csv").Sheets(ImprtFile).Range(Cells(tradeRow, 1), Cells(tradeRow, 12))
ws.Cells(pLR + 1, 13) = Acct

Sheets(Acct).Activate
End Sub
The left side of the equation is in the workbook with the VBA, the right side is an export file that I grab data and then close.

I know I’ve used this method within sheets of a workbook, but thought I’d done it with sheets between two workbooks, but maybe I’m wrong. Each side of the equation identifies the correct range in each workbook when that workbook is Active but otherwise fails.

I wrote out the code without any variables and it behaves the same way to ensure I didn't have an error there, but get the same results.

Code:
Workbooks("Trade Journal-2020 IIe2d-4e  Reset c.xlsb").Sheets("Pending").Range(Cells(3, 1), Cells(3, 12)) = Workbooks("2020-01-02-AccountStatementC.csv").Sheets("2020-01-02-AccountStatementC").Range(Cells(32, 1), Cells(32, 12))
Also, I used the document properties to store the values of variables defined in the general module that called the Userform.

Does anyone see the problem / have a suggestion? Thanks for reading.
↧
↧

Repeat copy / paste in next row

April 7, 2020, 9:34 pm
$
0
0
Hi

In the attached spreadsheet I've managed to get a random number generated in cell A9 to be pasted as a value in cell F9 then a new value in G9, then another new value in H9 etc on to cell K9. Once the code has done that it then moves down and repeats the task for cells F10, G10, H10 etc. I've achieved this by using offset, writing the revised code for each line. As I need to repeat the copy paste in sections of rows from 9-13, 16-20, 23-27 for 12 sections (60 lines), rather than write a new code for each line, is there a way the block of cells can be filled in using a loop or some such?

Thanks

Frankie
Attached Files
↧

VBA creating variable name not working

April 7, 2020, 10:27 pm
$
0
0
I'm using a button/macro to generate a new sheet based on a template and then create a reference card ("card") on the master sheet ("Board") that previews a couple cell references ("title" and "owner") on the new sheet and has a hyperlink to take you to the new sheet. My challenge is that I'm trying to use a variable name to ensure that the reference card links to the new sheet instead of the template and it isn't working. The first half of the code works great and copies the "template" sheet well and names it ("Id1, Id2, Id3, etc.") using a variable name (strNewName), but I can't seem to use that variable name with the referencing. My grouping also doesn't seem to be working. Any help you can offer would much appreciated.

HTML Code:
Sub copy_rename_template()
 
 Dim lngLoop As Long
 Dim wsTest As Excel.Worksheet
 Dim wsSource As Excel.Worksheet
 Dim Box As Shape
 Dim CardD As String
 Dim TitleA As String
 Dim OwnerB As String
 Dim LinkC As String
 Dim strNewName As String
 
 Const ROOTName As String = "Id"
 Const SourceSheet As String = "Template"
 Const MaxTries As Long = 1000
 
 '// Set a reference to the source sheet. If it does not exist then
 '// the standard debug window will be displayed
 Set wsSource = Sheets(SourceSheet)
 
 '// The code may raise errors - ignore, these are handled directly
 '// by the code
 On Error Resume Next
 
 '// Loop a max number of times. I've never seen
 '// a workbook with 150 worksheets, never mind 1000
 '// as defined here.. Change the CONST declaration to
 '// something a littl emore suitable for your needs
 For lngLoop = 1 To MaxTries
 
 '// Derive the new worksheet name
 strNewName = ROOTName & CStr(lngLoop)
 
 '// See if it exists already...
 Set wsTest = Sheets(strNewName)
 
 '// If wsTest is nothing then sheet SHCRx does not exist
 If wsTest Is Nothing Then
 
 '// Exit the loop. Finished here
 Exit For
 Else
 '// It does exist. Clear the reference to the worksheet
 Set wsTest = Nothing
 '// Clear the error
 Err.Clear
 End If
 
 '// If it gets to here then it loops again
 Next
 
 '// Last check - there's less than (1000) worksheets?
If lngLoop < MaxTries Then
 
 '// Copy the source sheet and place at end of sheets tab.
 wsSource.Copy After:=Worksheets(Worksheets.Count)
 
 '// Rename the new sheet. Only a general ACTIVESHEET reference
 '// as this will be the active sheet after the copy
 With ActiveSheet
 .Name = strNewName
 .Range("A1").Value = "Id" & CStr(lngLoop)
 '// OR
 '// .Range("A1").Value = strNewName
 End With
Else
 
 '// Tell user the sheet was not copied.
 MsgBox "Are you really going to work with " & CStr(MaxTries) & " worksheets...?", vbExclamation, "Don't be silly"
End If

 Worksheets("Board").Activate
 ActiveSheet.Shapes.Range(Array("Group 10")).Select
 Selection.Copy
 ActiveSheet.Paste.Name = "card"
 '// Copy and paste the group of inanimate objects from sheet "Board" and apply the variable name "card".
 
 ActiveSheet.Shapes.Range(Array("Rectangle 4")).Select
 Selection.Copy
 ActiveSheet.Paste.Name = "title"
 Selection.Formula = "='strNewName'!E3:O3"
 '// Copy and paste "rectangle 4" from the active sheet ("Board") and apply the variable name "title"
 '// have the new rectangle display the contents of cell E3:O3 (merged cell) from the newly-created sheet.

 ActiveSheet.Shapes.Range(Array("Rectangle 5")).Select
 Selection.Copy
 ActiveSheet.Paste.Name = "owner"
 Selection.Formula = "='strNewName'!M46"
 '// Copy and paste "rectangle 5" from the active sheet ("Board") and apply the variable name "owner"
 '// have the new rectangle display the contents of cell M46 from the newly-created sheet.

 ActiveSheet.Shapes.Range(Array("Rectangle 2")).Select
 Selection.Copy
 ActiveSheet.Paste.Name = "link"
 ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'strNewName'!A1"
 '// Copy and paste "rectangle 2" from the active sheet ("Board") and apply the variable name "link"
 '// hyperlink the shape to cell A1 on the newly-created sheet.
 
 ActiveSheet.Shapes.Range(Array("title", "owner", "link", "card")).Select
 Selection.ShapeRange.Group.Select
 '// Group the four objects that you've just copied and pasted
 
 Selection.ShapeRange.IncrementLeft -11.25
 Selection.ShapeRange.IncrementTop 115.5
 '// Move the group of four objects that you've just created to the large outlined box below

End Sub
Attached Files
↧

[SOLVED] VBA coding to print more than 1 sheets of worksheets in 1 go using only 1 button.

April 7, 2020, 10:57 pm
$
0
0
Hi all,

Please refer to the following codings.

Code:
Sub Rectangle2_Click()
    Sheets("AS9102 Form 1").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
End Sub
the above codings only manage to print 1 sheet for my worksheet.
I have a total of 3 sheets on my worksheet.
I currently used 3 buttons to print all 3 sheets.
How do I alter the codes to print all my 3 sheets in 1 go using only 1 button?
Do advise on this.

Much Thanks,
Regards,
Eugene
↧
Viewing all 49833 articles
Browse latest View live
Search