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

Get Caption From Userform CommandButton During Click Event Procedure

September 18, 2015, 10:15 pm
$
0
0
I have a command button and in the ClickEvent code, while it is running, I want to capture the caption of the command button.

I know I can access it by Me.CommandButton1.Caption and that's what I'm doing and my use of the caption is working perfectly.

I want to paste the heart of the code into 52 other command buttons and access the caption of each one without having to change the code.

I found on Ozgrid that I could use ActiveControl, it works if the command button is on a regular form, I've test it.

These command buttons are on multipages and when I use activecontrol it returns the multipage as the active control.

There's a property for the command button called TakeFocusOnClick and it's set to True, but that doesn't seem to be helping, for some reason the multipage and not the command button I clicked is considered the active control.

Any help would be appreciated.
↧
Search

[SOLVED] Delete Data & Subtotal Columns

September 19, 2015, 11:16 am
$
0
0
1. What I would like to accomplish is if I have a "1" in "Column I" that corrspond with text in "Column A" I would like to clear that cell as well as to clear the cell in "Column J:K".
2. Also If I have a "1" in "Column I" that corrspond with a blank cell in "Column A" I would like to clear that cell, as well as to clear the cell in "Column J:K"
3. I would like to be able to subTotal "Column N:O", "Column Q:S", and "Column U" that corrspond with the text "SubTotal *.*" in "Column E:H"

I have uploaded what my sheet looks like.

The information that you are looking at on sheet HDQRS is pasted from another sheet that has been exported from an estimating program that I use. The columns on this sheet are the same as the exported sheet. The SubTotal items will never fall in the same cell location, this is because some of the tasks have more tasks involved, but will always fall in the same column.

I hope this is not asking to much, but I would appreciate it very much to be able to run a marco on this.
Attached Files
↧
↧

Send Excel Spreadsheet as Email.

September 19, 2015, 11:18 am
$
0
0
Hi all,

I'm currently using the following script to attempt to send the contents of an Excel Spreadsheet as the body of text within an email.

Code:
Sub CommandButton1()
 
Dim NewMail As CDO.Message
 
Set NewMail = New CDO.Message
 
'Enable SSL Authentication
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
 
'Make SMTP authentication Enabled=true (1)
 
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
 
'Set the SMTP server and port Details
'To get these details you can get on Settings Page of your Yahoo Account
 
myMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.mail.yahoo.com"
 
myMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
 
myMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
 
'Set your credentials of your Gmail Account
 
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxxx@xxxx"
 
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "xxxxxxxxxxxxx"
 
'Update the configuration fields
NewMail.Configuration.Fields.Update
 
'Set All Email Properties
 
With NewMail
  .Subject = "Test Mail"
  .From = "xxxx@xxxx"
  .To = "yyyy@yyyy"
  .CC = ""
  .BCC = ""
  .TextBody = "This is a test"
End With
 
 
NewMail.Send
MsgBox ("Mail has been Sent")
 
'Set the NewMail Variable to Nothing
Set NewMail = Nothing
 
End Sub

Private Sub CommandButton2_Click()

End Sub
Whenever I run the code I get Error 424 'Object Missing' at this line of code:

Code:
myMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.mail.yahoo.com"
I have the CDO Library enabled.

My question is twofold:

How do I make the above script functional and working and...

How can I get it to copy the contents of the Spreadsheet and paste it as the body of the email, then send the email, all without user input.

Your assistance is much appreciated.
↧

[SOLVED] Union and Intersect Problems with Worksheet on Change Event

September 19, 2015, 11:31 am
$
0
0
Hello

I inherited a workbook for an audit where the original data is on one side and the auditors codes for the same data elements are on the other side. If the auditor changes data the cell turns yellow to indicate changes. Not all the columns in the range have data in them (the worksheet is more like a entry form than a worksheet with data side by side).

For instance, there is data in column B5 to B39 on the original side and K5 to K139 on the audited side; data in the range D41:G76 on the original side and M41:P76 on the audited side; B78 to I108 on the original side and K78 to R108 on the audited side.

The problem is that the way the code is written, it includes entire columns and now that I want to add another area to the worksheet below K109, I'm getting errors. Below is the code and I'm hoping someone can help me edit it? I've tried writing the ranges noted above for the rng source but it didn't work out. Note that the code below works now IF I didn't want to add something below K109. Thanks for any and all assistance.

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim t As Range, rng As Range
   
    Set rng = Union( _
        Intersect(Rows("5:39"), Range([b1], [k1]).EntireColumn), _
        Intersect(Rows("41:76"), Range([d1], [p1]).EntireColumn), _
        Intersect(Rows("78:108"), Range([b1], [r1]).EntireColumn), _
        Intersect(Rows("124"), Range([e124], [e124]).EntireColumn))
             
    'ensures date format of procedure dates is 2014-04-04
    Set rng2 = Range("K78:K108")
     
       
    For Each c In rng2
    If IsDate(c.Value) Then
    c.NumberFormat = "yyyy-mm-dd"
    End If
    Next c
   
    'ensures that when changes to codes that they turn orange
    For Each t In Target
        With t
       
        'is change in column K?
            If Not Intersect(t, rng, Cells(1, "K").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "B").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
       
      'is change in column L?
        If Not Intersect(t, rng, Cells(1, "L").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "C").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
        'is change in column M?
            If Not Intersect(t, rng, Cells(1, "M").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "D").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
           
        'is change in column N?
        If Not Intersect(t, rng, Cells(1, "N").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "E").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
       
      'is change in column O?
        If Not Intersect(t, rng, Cells(1, "O").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "F").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
       
        'is change in column P?
        If Not Intersect(t, rng, Cells(1, "P").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "G").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
           
        'is change in column Q?
        If Not Intersect(t, rng, Cells(1, "Q").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "H").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
                       
        'is change in column R?
            If Not Intersect(t, rng, Cells(1, "R").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "I").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
             
            Select Case Target.Value
            Case "Complete - Changes"
            Me.Tab.Color = 16711680
            'blue
            Case "Follow up required"
            Me.Tab.Color = 204
            'red
            Case "Complete - No Changes"
            Me.Tab.Color = 26112
            'green
            Case "Not Audited"
            Me.Tab.Color = 10498160
            'purple
            Case "Complete - Optional Changes"
            Me.Tab.Color = 5296274
            'light green
            Case "Data Quality Flag"
            Me.Tab.Color = 26367
            'orange
           
            End Select
     
        End With
    Next
        Set rng = Nothing
       
         
End Sub
↧

ADODB Connexion - Update Excel file

September 19, 2015, 11:47 am
$
0
0
Hello all,

I need your help.

I implemented a macro allowing to handle hundreds of excel files (as input datasource) containing different huge matrix of data.
The macro load everything in memory, transform the data in structured objects in memory and finally wrote formatted results in excel sheet allowing KPI analysis,... ect...
I do not open the files, I read them using ADODB connection (more efficient than open the files, no comparison in performance). In 99% of the case everything is working very well except in one case occurring in some input files.

Those input files contain 1 column with different type of data (date, text, numbers, null,...), all cells of this column return null values by my recordset even if data exist. I tried many solutions and played a lot with almost connectionstring possible in ADODB based on JET, ACE.OLEDB.12.0 or ODBC MSDASQL and Extended Properties.... In all case I get the issue on this column retruning null values.
I discovered that if I remove manually the content of cell M12, a date, the issue does not occur. I tried via an ADO query to replace the date automatically but unsuccessfully...

In summary I have 2 options to solve my issue:
1-find a connectionstring or a way to read the data without losing data in column M
2-succeed to replace the content of the cell via a query

I can attach an example of on input file in which the issue occur if you require it.

Here is my connection string to read data:
Code:
Function getFileConnectionString(strPathFile As String) As String
getFileConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPathFile & ";Extended Properties=""Excel 12.0 Xml;HDR=No;MAXSCANROWS=1;TypeGuessRows=0;IMEX=1;ReadOnly=False"";"  '
End Function
This code is working well except for the described issue...

Here is the code I implement to replace the content of the cell via a query without opening the files.
Code:
strQuery = "SELECT top 7 * FROM [Training Overview$] where F13 is not null"
On Error Resume Next
objRS.Open strQuery, objCon, adOpenDynamic, adLockOptimistic, adCmdText
If Err.Number <> 0 Then
    exit function
End If
On Error GoTo 0
'--------------------------------------
'Debug.Print objRS!F13
objRS!F13 = ""
objRS.Update
Debug.Print Err.Description
objRS.Close
objCon.Close
This code return the following error message:[Microsoft][ODBC Excel Driver] Syntax error (missing operator) in query expression '(F1=Pa_RaM001 AND F2 IS NULL AND F3 IS NULL AND F4 IS NULL AND F5 IS NULL AND F6 IS NULL AND Training Overview=Pa_RaM002 AND F8 IS NULL AND F9 IS NULL AND F10 IS NULL AND F11 IS NULL AND F12=Pa_RaM003 AND F13=Pa_RaM004 AND F14 IS NULL )'.



Does someone of you can help me?

Kind regards,

Dragomer

PS: My english is not excellent, do not hesitate to ask clarification, I'm sorry
↧
↧

New to VBA, can't get the following to run

September 19, 2015, 2:01 pm
$
0
0
Brand new to this. Trying to get the following code I found online to run in powerpoint. I get the "expected end sub" error.

Code:
Sub CommandButton1_Click()
Dim hat As New Collection
Sub fill_the_hat()
Dim items() As String
Dim x As Long
If hat.Count > 0 Then Call empty_the_hat
items = Split("Mary\Bill\John\Dawn\Ann\Colin", "\")
For x = 0 To UBound(items)
hat.Add (items(x))
Next x
End Sub

Sub empty_the_hat()
Dim x As Long
For x = 1 To hat.Count
hat.Remove (x)
Next x
End Sub

Sub pick_one()
Dim x As Long
If hat.Count = 0 Then
MsgBox "All drawn"
Exit Sub
End If
Randomize
x = Int(Rnd * hat.Count) + 1
MsgBox hat(x)
hat.Remove (x)
End Sub
↧

what is wrong with that code ?

September 19, 2015, 2:21 pm
$
0
0
what is wrong with that code ?
this code simply act as search engine , when a value selected from dorpdown menus it filter another worksheet and copy result and past it in the search engine page , it works fine except for this part , it returns the full sheet with no filter applied on field 6 , i can't figure why , while the same code ( with changes in fields and search criteria works with other cells ,,, it return all other values as it should except for this critera , any support ?

Code:
  Dim Val As String
  Val = Sheets("Search Engine Page").Range("C11").Value

If Sheets("Search Engine Page").Range("C14").Value = "" Then
 GoTo All_Teams
End If
Sheets(Val).Select
 If Worksheets("Search Engine Page").Range("C14").Value = "All" Then
All_Teams:
  ActiveSheet.Range("$A$9:$AB$200").AutoFilter Field:=6
GoTo formating
End If

If Worksheets("Search Engine Page").Range("C14").Value = "Team one" Then
  ActiveSheet.Range("$A$9:$AA$28").AutoFilter Field:=6, Criteria1:=Array( _
        "Mem1", "Mem2", "Mem3"), Operator:=xlFilterValues
End If
If Worksheets("Search Engine Page").Range("C14").Value = "Team two" Then
      ActiveSheet.Range("$A$9:$AA$28").AutoFilter Field:=6, Criteria1:=Array( _
        "Mem4", "Mem4", "Mem5"), Operator:=xlFilterValues
End If
If Worksheets("Search Engine Page").Range("C14").Value = "Team three" Then
  ActiveSheet.Range("$A$9:$AA$28").AutoFilter Field:=6, Criteria1:=Array( _
        "Mem6", "Mem7", "Mem8", "Mem8"), Operator:= _
        xlFilterValues
End If
If Worksheets("Search Engine Page").Range("C14").Value = "Team four" Then
    ActiveSheet.Range("$A$9:$AA$28").AutoFilter Field:=6, Criteria1:= _
        "Mem9"
End If


formating:

   
    Rows("9:200").Select
    Selection.Copy
    Sheets("Search Engine Page").Select
    ActiveWindow.SmallScroll Down:=9
    Rows("25:25").Select
    ActiveSheet.Paste
  ActiveWindow.SmallScroll Down:=6
    Cells.Select
    Range("A25").Activate
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Cells.EntireColumn.AutoFit
  Sheets(Val).Select
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$9:$AB$200").AutoFilter Field:=9
    ActiveSheet.Range("$A$9:$AB$200").AutoFilter Field:=4
    ActiveSheet.Range("$A$9:$AB$200").AutoFilter Field:=6
    ActiveSheet.Range("$A$9:$AB$200").AutoFilter Field:=21
    Sheets("Search Engine Page").Select
    Range("A25").Select
    ''
    Cells.EntireRow.AutoFit
    Rows("9:9").Select
    Selection.AutoFilter
    Rows("25:25").Select
    Selection.AutoFilter
    Range("A25:AB25").Select
    Selection.AutoFilter
    Range("A25").Select
    Cells.EntireColumn.AutoFit
    Range("A25").Select
  ActiveWindow.SmallScroll Down:=-6
jumb:
↧

Macro to autofill cells and delete some rows and columns

September 19, 2015, 3:27 pm
$
0
0
I better start with saying that I'm an Excel rookie, so I know very little (next to nothing) about macro programming, and I only know basic formulas.

I have a set of data with a large number of rows, and I only need the rows that has data in column C. Therefore I would like to delete all rows, where the cell in column C is empty, to make the data set smaller for the calculations in the other sheets.
First, however, I would like to fill column L with numbers, so that it automatically fills a given cell i column L with the number in the cell above, unless that row has the value "1" in column A.

I attached the file to make it easier to understand, as English is not my first language, so it possibly could be difficult to understand what I mean...

This is a list of plays in american football games. The column A is the play number of every game, and in column L the first play of each game has the game #. So I want the game number to be filled into all rows of that game, but when the next game starts (column A has the value "1" again) the new game # should be filled to all the plays of that game and so on. All the text notes in column L can be overwritten, they are not used for anything in this document.
Then I would like to delete all plays that has no penalties (column C), to make the data set smaller, as it shall be used for penalty statistics, so I only need the plays with penalties. Finally I would like it to delete columns B, I, J, K, M and N as they are not used for anything in this document.

The macro should be able to put in a button that is placed in the "sheet1" sheet, as the whole "data" sheet is imported from a website, so if the button is placed there, it will be deleted when I get a new data set from the website, as more games are played.

I hope that it is understandable...

PlaylistData_W1-W17.xlsx
↧
Search

A lot of workbooks into ONLY one. Can you check this code please?

September 19, 2015, 4:18 pm
$
0
0
Hello,

I need to merge a lot of workbooks into only one workbook.
All the workbooks have only one sheet inside and they all have the same columns.

This code I found on the internet It works But I would need that it let more than 65536 rows (the output file will have about 200'000 rows)

Code:
Sub simpleXlsMerger()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")
 
'change folder path of excel files here
Set dirObj = mergeObj.Getfolder("D:\change\to\excel\files\path\here")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)
 
'change "A2" with cell reference of start point for every files here
'for example "B3:IV" to merge all files start from columns B and rows 3
'If you're files using more than IV column, change it to the latest column
'Also change "A" column on "A65536" to the same column as start point
Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
 
'Do not change the following column. It's not the same column as above
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Next
End Sub
how can I modify it?
on this code the limitation of 65536 rows It concern also the output file? (....or It is about only the "read" files)?



Thanks
↧
↧

[SOLVED] Continuously Generate Random Numbers Until Minimum Reached entirely with VBA

September 19, 2015, 5:04 pm
$
0
0
Hey all,

I'm try to make my userform generate 6 random number that all meet a minimum value. I'd like to do this without cell references, so entirely within the VBA code. I've tinkered around and can't seem to make it work. Some tries did nothing, some ignored the minimum. Here's an example of the code I'm using.

Code:
Do While TextBox1.Value < MinimumNumberTextBox.Value
        Randomize
        MyNumber = Int((20 - 1 + 1) * Rnd + 1)
        TextBox1.Value = MyNumber
       
       
    Loop
I'm afraid there's circular logic stuff that might be preventing it from working, but not sure how to remedy. There will be six text boxes in total, so unless there's a way to make it look at each one in turn, I'll just end up running this six times in a row referencing different textboxes. If anyone can shed some light I'd be very greatful.
↧

Need help transferring data from a "template" into a tracking log

September 19, 2015, 6:14 pm
$
0
0
So I have been given a spreadsheet with 2 tabs. The first tab, called FORM, has the input data for customers, basically a form. Once the form is filled out, I need to pull the input data into the 2nd tab called Tracker, which is a running total of all the inputs.

The problem is that I can't just link the FORM tab into the Tracker tab because the FORM tab is just replaced and overwritten with new customer data each time a new order is created.

So, what would be the best option to pull in and add to the next available row on the Tracker tab, anytime a new entry is made on the FORM. I can just do a macro that once the form is filled, have it paste all the data onto the Tracker tab, but I'm having trouble having it paste the table on the next available row.

To summarize,

If I input data into cells on a sheet called FORM, I then want those cells to be copied to the Tracker sheet on the next available row automatically. I can't just link to the FORM tab because the data is replaced and overwritten each time a new item is entered.

Hope this makes sense. Any help would be appreciated.
↧

UDF for Converting Bond Price in Ticks to Decimal Number Format

September 19, 2015, 6:36 pm
$
0
0
I have two long formulas that I am trying to turn into a UDF because I use them frequently, and I am new to VBA.

The first formula converts the tick price (Agency MBS convention) into a decimal number. The convention is shown below.
Formula: 
=LEFT(A1,FIND("-",A1)-1)+(LEFT(SUBSTITUTE(RIGHT(A1,LEN(A1)-FIND("-",A1)),"+","4"),2)+IFERROR(MID(SUBSTITUTE(RIGHT(A1,LEN(A1)-FIND("-",A1)),"+","4"),3,1)/8,0))/32

ticktodec.PNG

For 104-084, the "08" to the right of "-" represents 8/32's and the third number represents 4/8 of 1/32 or alternatively 4/256. The "+" means half of 1/32 or 4/256 as well.

I created a UDF for this formula(=Pxd(n)), but it only works for 2 of the 4 different tick formats I need.

Code:
Function Pxd(n)
Pxd = Left(n, WorksheetFunction.Find("-", n) - 1) + (Left(WorksheetFunction.Substitute( _
    Right(n, Len(n) - WorksheetFunction.Find("-", n)), "+", "4"), 2) _
    + WorksheetFunction.IfError(Mid(WorksheetFunction.Substitute(Right(n, Len(n) - _
    WorksheetFunction.Find("-", n)), "+", "4"), 3, 1) / 8, 0)) / 32
End Function
I tried to create a UDF for the second formula, which reverses the formula and converts decimals to ticks but kept running into errors.
Formula: 
=INT(A2) & "-"&IF(LEN(ROUNDDOWN((A2-INT(A2))*32,0))=1,"0"&ROUNDDOWN((A2-INT(A2))*32,0),ROUNDDOWN((A2-INT(A2))*32,0))&VLOOKUP((ROUNDDOWN((A2-INT(A2))*256,0)/8)-INT(ROUNDDOWN((A2-INT(A2))*256,0)/8),{0,0;0.125,1;0.25,2;0.375,3;0.5,"+";0.625,5;0.75,6;0.875,7;1,8},2,0)

dectotick.PNG

How do I fix the first UDF and how should I set up the UDF for the second formula? Thank you in advance for any help you can provide.
Attached Files
↧

[SOLVED] Combobox list for two columns or match two different column ranges

September 19, 2015, 7:52 pm
$
0
0
I have tried looking this up but all I get is two columns within the the combobox. What I want is for vba to search two columns and suggest cell contents from both without taking a long time. I have tried looking into arrays but that is way above my knowledge level when I tried to read it.

Namecb is my combobox

Right now I have this in Namecb_Change(), but it is terribly slow:
Code:
    Sen = Application.Match(Namecb.Value, ws1.Columns(1), 0)
    If IsError(Sen) Then
        Me.Namecb.List = Worksheets("Total Guests").Range("B:B").Value
    Else
        Me.Namecb.List = Worksheets("Total Guests").Range("A:A").Value
    End If
This is in my initialize:
Code:
Public Sub UserForm_initialize()
Me.Namecb.List = Worksheets("Total Guests").Range("A:A").Value
Is there a way to make this run faster or another way to do it?
↧
↧

MsgBox_Clear Col not matchN the DaYte in a cEll (on 2Nd Tab) -UpdAte the TOt@l via Macro

September 19, 2015, 8:34 pm
$
0
0
Clear Columns that don't match the date in a Cell located on another sheet and Update the Sum formulae in another column via macro

Enclosed Attachment
Attached Files
↧

Duplicating selected table rows

September 19, 2015, 8:48 pm
$
0
0
Hi Guys,

I need help with my code for duplicating table rows. Currently, this is what i have

Code:
    Dim rng As Range
   
    Dim shtControlAssignment As Worksheet
   
    Set shtControlAssignment = ThisWorkbook.Worksheets(cstrControlAssignment)

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    On Error Resume Next
    With Selection.Cells(1)
        Set rng = Intersect(.EntireRow, ActiveCell.ListObject.DataBodyRange)
        On Error GoTo 0
        If rng Is Nothing Then
            MsgBox "Please select table row.", vbCritical
        Else
            If MsgBox("Proceed to duplicate selected rows? Yes/No.", vbQuestion + vbSystemModal + vbYesNo, cProjName) = vbYes Then
       
        'Set your range
        Set rng = .Rows(ActiveCell.Row)
       
        'Insert the range
        rng.Offset(1).Insert Shift:=xlDown
   
       
        'Copy and Paste the Selected range

        Selection.Copy

        ActiveCell.Offset(1).PasteSpecial
       
        'Clear the clipboard.
        Application.CutCopyMode = False
       
            End If
        End If
    End With
but i keep getting the error "The operation is not allowed. The operation is attempting to shift cells in a table in your worksheet."

Can you give me a sample code to duplicate the current selected row in a table?

thank you so much in advance
↧
Search

Getting compile error sub or function not defined

September 19, 2015, 10:31 pm
$
0
0
Hi friends,
I’m getting compile error ‘sub or function not defined’.
I want to color the range ‘B:I’ if the event is due on date.
If no event is due then I want a message with a date.

Everything else is working fine.

Please see the attached workbook and suggest me a correction in code.

Thanking you in anticipation.
Attached Files
↧

Preventing a range to be split on two pages A4

September 20, 2015, 9:39 am
$
0
0
Hi again,

Does anybody know how to do this?
I ve tried with property
Code:
.Rows.AllowBreakAcrossPages = False
But it isnt a table, just few cells, some of them are merged unfortunately..

Logic should be, if there any room for all twelwe cells on paper put it there, else copy on the begining of new a4 page.

It would be for i=1 to 'as much pages is created. The text above will generate automatically from userForm..

Please find attachment below.

Thanks!
Attached Files
↧
↧

UDF to fetch value from another sheet gives #NAME? error

September 20, 2015, 9:50 am
$
0
0
Hi,


I'm trying to create a UDF that can fetch a value from a cell in another sheet. It gives a #NAME? error, though.

The way I want it to work is this:
As input, it takes two cell references and a value, e.g.;
=ValueFetcher(A9;C9;1)

One cell (A9) contains the name of the sheet to look in. One cell (C9) contains a Column name, "ColName". The UDF should then, in that sheet:
1 Search cells A1:A50 to find a cell with the string "Country"
2 In the row X when the A-cell is "Country", it should search the 50 cells to the left of cell AX for the value "ColName".
3 When it has identified this, if should go down by 1 cell (as the "1" specified when calling the function
4 And lastly, it should give back the value of this cell


This is my unsuccessful attempt, that gives the #NAME? error. Any input on this would be greatly appreciated.

Alfred


Code:
Public Function ValueFetcher(SheetName As Range, ColName As Range, DownByX As Integer) As Integer
 
Dim SearchColumn As Range
Dim ColVar As Range
Dim SearchRow As Range
Dim TargetCell As Range


Set SearchColumn = Sheets(SheetName).Range("A1:A50")

For Each Cell In SearchColumn
    If Cell.Value = "Country" Then
        ColVar = ActiveCell.Address
    Else
        Exit For
    End If
Next

Set SearchRow = Sheets(SheetName).Range(ColVar, ColVar.Offset(0, 50))

For Each Cell In SearchRow
    If Cell.Value = ColName Then
    TargetCell = ActiveCell.Offset(DownByX, 0)
Else
    Exit For
End If
Next

ValueFetcher = TargetCell.Value

End Function
↧

Email Dynamic Range Issue

September 20, 2015, 12:23 pm
$
0
0
Good afternoon!

I'm fairly new to VBA (most of my excel knowledge up to this point has been googling errors) and I've ran into an issue that I cannot find a fix to. I'm using the following code to set up an auto email of a specific range and it works fine if this line,

Code:
Set Rng = Range("A14:N29").SpecialCells(xlCellTypeVisible)
Has specific ranges selected. However I'd like to make the second part of that range dynamic, for this example where I have "N29" it would relate to a specific cell value where I have a formula calculating the correct cell. The formula is looking up a cell column in a reference row and putting it together with a specific ending row number such as 13. Basically I want to select this range and email it but make it dynamic based off of the reference cell. I've tried to use the following but run into an error,

Code:
Set Rng = Range("A14:C38.value").SpecialCells(xlCellTypeVisible)
Any help would be greatly appreciated!

Code:
Sub ramp_class1()
    Dim olApp As Object
    Dim olMailItem As Object
    Dim Dest As Variant
    Dim SDest As String
    Dim signature As String
    Dim Rng As Range
    Dim Header As String
   
    'MsgBox'
    Header = "Send RAMP Update"
    reqfields = "Required fields are not complete." & vbNewLine & vbNewLine & "- Client" & vbNewLine & "- Class Size" & vbNewLine & "- Class Date"
    confirm = "Are you sure?"
   
    'Required Fields Check'
    If ActiveSheet.Range("C6").Value = "" Or ActiveSheet.Range("C7").Value = "" Or ActiveSheet.Range("C8").Value = "" Then
    response = MsgBox(reqfields, , Header)
    Exit Sub
    End If
   
    'Confirmation Box'
    response = MsgBox(confirm, vbYesNo, Header)
    If response = vbNo Then
    Exit Sub
    End If
   
    Set Rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection'
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)'
    'You can also use a range if you want'
    Set Rng = Range("A14:N29").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
   
    'Create the Outlook Application and empty email'
    Set olApp = CreateObject("Outlook.Application")
    Set olMailItem = olApp.CreateItem(0)
   
    'Recipients'
    SDest = "lee.jackson@asurion.com"
   
    'Format email'
    With olMailItem
    .Display
    End With
        signature = olMailItem.htmlbody
    With olMailItem
        .To = SDest
        .Subject = ActiveSheet.Name & " " & Range("C8").Value & " Class Ramp Week - " & "(" & Range("I8").Value & ")"
        .htmlbody = RangetoHTML(Rng) & signature
        .Display
    End With
   
    'Clean up the Outlook application'
    Set olMailItem = Nothing
    Set olApp = Nothing
   
End Sub
Function RangetoHTML(Rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
Rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=left x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close SaveChanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
↧

Find and replace macro - cells immediately to the right

September 20, 2015, 12:49 pm
$
0
0
I'd like to create a find and replace macro with an additional element.

I'd like to select a column manually. The macro should then identify text/numbers of my choosing (call it [TEXT TO BE FOUND]) within the selected area. However, rather than replacing it with new text, it should paste the replacement text in the column immediately to the right of where [TEXT TO BE FOUND] is.

Can anyone help? Hopefully this is clear but I can add before and after spreadsheets if not.
↧
Viewing all 49892 articles
Browse latest View live
Search