Writing a macro for a spreadsheet in excel - excel

I need to write a spreadsheet which when you press a button adds a row of data and asks for the parameters needed for the calculations, but I cant seem to get it right, its really frustrating me, any help would be appreciated. I am a complete begginner to macros in excel and have only done very basic programming for matlab on my uni course. My script so far is as follows:
Sub AddPosTol()
'
' AddPosTol Macro
'
Dim rngSeek As Range
Set rngSeek = Range("A1").End(xlDown).Offset(1, 0)
With rngSeek.Offset(0, 1)
With .Font
.Name = "Solid Edge ANSI1 Symbols"
.Size = 11
End With
End With
Range(rngSeek).Offset(0, 1) = "l"
Range(rngSeek).Offset(0, 3) = "=RC[-1]"
Range(rngSeek).Offset(0, 4) = "0"
With rngSeek.Offset(1, 1)
With .Font
.Bold = True
End With
End With
Range(rngSeek).Offset(1, 1) = "X value"
Range(rngSeek).Offset(2, 1) = "Y Value"
Range(rngSeek).Offset(0, 4) = "=2*SQRT((R[1]C[-3]-R[1]C)^2+(R[2]C[-3]-R[2]C)^2)"
Range(rngSeek).Offset(0, 5) = "=2*SQRT((R4C3-R[1]C)^2+(R5C3-R[2]C)^2)"
Range(rngSeek).Offset(0, 6) = "=2*SQRT((R[1]C[-3]-R[1]C)^2+(R[2]C[-3]-R[2]C)^2)"
Range(rngSeek).Offset(0, 7) = "=2*SQRT((R[1]C[-3]-R[1]C)^2+(R[2]C[-3]-R[2]C)^2)"
Range(rngSee).Offset(0, 8) = "=2*SQRT((R4C3-R[1]C)^2+(R5C3-R[2]C)^2)"
Range(rngSeek).Offset(0, 2) = (InputBox("Insert Positional Tolerance Diametre"))
Range(rngSeek).Offset(1, 2) = (InputBox("Insert X value on drawing"))
Range(rngSeek).Offset(2, 2) = (InputBox("Insert Y value on drawing"))
End Sub

You've defined rngSeek as a range and then are trying to use that range definition with the Range() method of the worksheet.
All the lines where you have Range(rngSeek).Offset(... you can replace with rngSeek.Offset(...
(One of your formula also references the wrong cells ;-)

Related

How do I output a value without placing it into the worksheet?

I have a pretty simple Sub that contains the following code -
Sub UnitNetCheck()
Dim UnitValue As Integer
Dim NetArea As Long
If Not [COUNTA(F2:F250)=0] Then
For UnitValue = 2 To 250
Cells(UnitValue, 26) = Cells(UnitValue, 4) * Cells(UnitValue, 6)
If Cells(UnitValue, 26) = 0 Then
Cells(UnitValue, 26).Value = ""
Else
End If
Next
Else
NetArea = Cells(Rows.Count, 7).End(xlUp).Row
Worksheets("Sheet1").Range("Z2:Z" & NetArea).Value =
Application.Transpose(Worksheets("Sheet1").Range("G2:G250").Value)
End If
End Sub
This sub UnitNetCheck, right now all it does is multiply some cells with some other cells and places the values in Z2:Z250.
Instead of it outputting the values into the specific range noted, I would like to instead use the output in other code without it populating on the worksheet.
What I would like to do is later use the sub as part of a worksheet SUMIF function as Sumif("defined range")("defined criteria")(UnitNetCheck Sub).
To save the data for later use in code, you need to create a module level variable (like a global in other languages) that is an array type.
First step is to create the array, so from the VBA Editor menu, select Insert->Module, then past the following:
'Declare the array inside a module file
Dim CellData(250)
Next step is to save the data from your existing code, like this:
For UnitValue = 2 To 250
Cells(UnitValue, 26) = Cells(UnitValue, 4) * Cells(UnitValue, 6)
If Cells(UnitValue, 26) = 0 Then
Cells(UnitValue, 26).Value = ""
Else
'Save in array for later use
CellData(UnitValue) = Cells(UnitValue, 26).Value
End If
Next

excel concatenate text with newline character and changing format of few lines

I have excel sheet as follow
cell a1 has text- 1234
cell d1 has text- abc.com
cell f1 has text- AZ, USA 85663
I created a formula in cell i1 as =CONCATENATE("Gaaa Reference No. I-20-",A1,CHAR(10),D1,CHAR(10),F1)
Then used steps in this link to concatenate three columns with newline character in between lines.
I want the first line to be bold, second line in italics. The output should be times new roman font. I tried changing formatting of columns a and d, but it didnt help
How could I change the formatting? The current output is as below
I have an excel sheet with multiple rows populated. I would like to have same format for the entire column I
It seems that this requires VBA code. Please provide that
Insert a new code module in VBA and use the following code...
Option Explicit
Sub FormatConcatColumn()
Dim i&, rows&, LF, v1, v2, v3, vOut, r As Range
rows = 60 '<-- change to 200 or however many rows you need
ReDim vOut(1 To rows, 1 To 1)
ReDim LF(1 To rows, 1 To 2)
With [a1].Resize(rows)
v1 = .Value2
v2 = .Offset(, 3).Value2
v3 = .Offset(, 5).Value2
For i = 1 To rows
vOut(i, 1) = v1(i, 1) & vbLf & v2(i, 1) & vbLf & v3(i, 1)
LF(i, 1) = Len(v1(i, 1))
LF(i, 2) = LF(i, 1) + Len(v2(i, 1))
Next
With .Offset(, 8)
.Clear
.Value2 = vOut
.Font.Name = "Times New Roman"
i = 0
For Each r In .Cells
i = i + 1
r.Characters(1, LF(i, 1)).Font.FontStyle = "Bold"
r.Characters(LF(i, 1) + 1, LF(i, 2) - 2).Font.FontStyle = "Italic"
DoEvents
Next
End With
End With
End Sub

Deselecting a chart in Excel VBA

In reference to the following file.xlsm:
where Sheet1 (1) is a Sheet, Plot1 (2) is a Graphic-Sheet and the button (3) refers to the following Macro:
Sub plot()
ReDim blue(1 To 5, 1 To 2)
ReDim red(1 To 5, 1 To 2)
For i = 1 To 5
blue(i, 1) = i
blue(i, 2) = i ^ 2
red(i, 1) = i + 4
red(i, 2) = (i + 4) ^ 2
Next i
Sheets("Plot1").Select
ActiveChart.ChartArea.ClearContents
ActiveChart.ChartArea.Select
ActiveChart.ChartType = xlXYScatterSmoothNoMarkers
ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(1).XValues = Application.Index(blue, , 1)
ActiveChart.FullSeriesCollection(1).Values = Application.Index(blue, , 2)
ActiveChart.FullSeriesCollection(1).Select
Selection.Format.Line.ForeColor.RGB = RGB(0, 0, 255)
ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(2).XValues = Application.Index(red, , 1)
ActiveChart.FullSeriesCollection(2).Values = Application.Index(red, , 2)
ActiveChart.FullSeriesCollection(2).Select
Selection.Format.Line.ForeColor.RGB = RGB(255, 0, 0)
Sheets("Plot1").Protect DrawingObjects:=True, Contents:=False
Sheets("Plot1").Unprotect
Sheets("Sheet1").Select
End Sub
after opening file.xlsm, clicking (3) and (2) I get:
after opening file.xlsm, clicking (2), (1), (3) and (2) I get:
How can I change the Macro so that I always get the third image regardless of the click sequence?
It used to be possible to deselect a chart, that is, an embedded chart, but I don't remember if it worked on a chart sheet.
For some reason, no matter what I try, the chart area becomes selected when this code is first run after opening the workbook. (I even tried activating the chart sheet, then the worksheet, with a Workbook_Open procedure: no luck.) But you can avoid having the second series selected if you don't select it in the first place. Not selecting things actually makes the code run faster, usually not enough that you would notice, but it also prevents the little flash of tabs being activated.
Sub plot()
ReDim blue(1 To 5, 1 To 2) As Double
ReDim red(1 To 5, 1 To 2) As Double
Dim i As Long
For i = 1 To 5
blue(i, 1) = i
blue(i, 2) = i ^ 2
red(i, 1) = i + 4
red(i, 2) = (i + 4) ^ 2
Next i
With Charts("Plot1")
.ChartArea.ClearContents
.ChartType = xlXYScatterSmoothNoMarkers
With .SeriesCollection.NewSeries
.XValues = Application.Index(blue, , 1)
.Values = Application.Index(blue, , 2)
.Format.Line.ForeColor.RGB = RGB(0, 0, 255)
End With
With .SeriesCollection.NewSeries
.XValues = Application.Index(red, , 1)
.Values = Application.Index(red, , 2)
.Format.Line.ForeColor.RGB = RGB(255, 0, 0)
End With
End With
End Sub

Adding complexity to an if then else loop

I've got a macro that works perfectly but that I now need to customize it and add complexity.
The macro is basically the following code repeated numerous times for a variety of ranges.
For i = 2 To n
Range(Cells(13, i), Cells(19, i)).Value = Sheets(i).Range("J13:J19").Value
Next i
The logic/complexity that I need to add to this should go as follows:
if the sum of the range O13:O19 on sheet i is greater than zero, then the value of the range cells(13,i),cells 19,i) on this sheet are equal to the value of the range p13:p19 on sheet i.
If the value of the sum of range O13:O19 on sheet i is not greater than 0, then set the value of the target range equal to each cell in (range sheet(i).range("I13:I19")-sheet(i).range("K13:K19")*4).value
In simpler terms, if the sum of the range is 0, set the value of every cell in range A to the value of every cell in range b less the (value of every cell in range C * 4)...
Sub Op_ex_analysis_macro()
ActiveWorkbook.Sheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "Control Panel"
Range("A:A").ColumnWidth = 36
Range("A12").Value = "Property Code"
Range("A13:A16") = Sheets(2).Range("A13:A16").Value
Range("A17") = Sheets(2).Range("B17").Value
Range("A18") = Sheets(2).Range("A18").Value
Range("A19") = Sheets(2).Range("B19").Value
Range("A20:A29") = Sheets(2).Range("A21:A30").Value
Range("A30") = Sheets(2).Range("B31").Value
Range("A31") = Sheets(2).Range("A33").Value
Range("A32:A36") = Sheets(2).Range("A35:A39").Value
Range("A37:A38") = Sheets(2).Range("A41:A42").Value
Range("A40").Value = "Analyst"
Range("A41").Value = "Number of Units"
Range("A42").Value = "Asset Manager"
Range("A43").Value = "Tenancy"
Range("A44").Value = "Year Built/Type"
Range("A45").Value = "Management Company"
Range("A46").Value = "End of Compliance Year"
Range("A47").Value = "Property Name"
Range("A48").Value = "Number of Properties"
Range("A49").Value = "City"
Range("A50").Value = "State"
'Consolidate Property Codes
n = ActiveWorkbook.Sheets.Count
For i = 2 To n
Z = Sheets(i).Range("P49").Value
Cells(12, i) = Z
Next i
'Consolidate rows 13-19
For i = 2 To n
Select Case Application.Sum(ThisWorkbook.Sheets(i).Range("O13:O33"))
Case Is > 0
Range(Cells(13, i), Cells(19, i)).Value = Sheets(i).Range("P13:P19").Value
Case Is = 0
Range(Cells(13, i), Cells(19, i)).Value = ThisWorkbook.Sheets(i).Range("I13:I19") - ThisWorkbook.Sheets(i).Range("K13:K19") * 4
End Select
Next i
In this case i think the best option is to use a Select case statement.
For i = 2 To n
Select Case Application.Sum(ThisWorkbook.Sheets(i).Range("O13:O33"))
Case Is > 0
Range(Cells(13, i), Cells(19, i)).Value = Sheets(i).Range("P13:P19").Value
Case Is < 0
Range(Cells(13, i), Cells(19, i)).Value = ThisWorkbook.Sheets(i).Range("I13:I19") - ThisWorkbook.Sheets(i).Range("K13:K19") * 4
End Select
Next i
Hope this helps :)
EDIT If ou want to account for whent it's "0" then just add a Case Is 0
After a lot of trial and error, I was able to solve the problem through via a different route.
As A.S.H correctly noted above, you can't do arithmetic on VBA arrays.
The first half of my code was basically moving an array, as Scott Craner noted on a different page, which is simple.
Directing VBA to perform calculations requires the coder to send the formula through a range cell by cell.
Ultimately, the code that performed as required was as follows:
Dim rng As Range
n = ActiveWorkbook.Sheets.Count
With ActiveSheet
For i = 2 To n
If Application.Sum(Sheets(i).Range("O13:O33")) > 0 Then
.Range(.Cells(13, i), .Cells(19, i)).Value = Sheets(i).Range("P13:P19").Value
Else
For Each rng In .Range(.Cells(13, i), .Cells(19, i))
rng.Value = Sheets(i).Cells(rng.Row, "I") - (4 * Sheets(i).Cells(rng.Row, "K"))
Next rng
End If
Next i
End With
If the condition of the first 1/2 of the if statement is met, then it's just set these values equal to those values. If the condition is not met, then the Else statement directs Excel to move through the range performing the calculation as it goes.

Microsoft Excel 2010 Web Query Macro: Pulling Multiple Pages From One

I am looking to find some help on this Macro.. The idea is, upon execution the Macro will pull The Data from a Web Page (I.E http://www.link.com/id=7759) and place it into let's say Sheet2, and then Open up Page 2, and place it right below Page 1's Data in Sheet 2.... And So on and So on until a set Page Number.. Ideally I would like it just to pull The following in order;
Title
Artist
Type
Paper Size
Image Size
Retail Prize
Quantity
And further more it is ideal that is placed in proper columns and rows of 4 and 8 Rows down(Columns Across just like in the web page).
Any help on this would be greatly, greatly appreciated. I have done some research and found similar macros, sadly have had no luck getting them to work for me. Mainly VB's fail to go through as well.
Bit of useful info (maybe) I figured this out when I was trying to write my own, maybe it will save who ever helps some time..
.WebTables = "8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38"
Those are the tables for each item I want to put into the Que...
Here's a sample method to get you going
Based on a few assumptions
Workbook contains a Sheet to hold query data called "Query"
Workbook contains a Sheet to put the data in called "AllData"
All old data is removed on running the macro
I think you need to include Table 7 in the qyuery
Pages to process is hard coded as For Pg = 1 To 1 , change this to suit
.
Sub QueryWebSite()
Dim shQuery As Worksheet, shAllData As Worksheet
Dim clData As Range
Dim qts As QueryTables
Dim qt As QueryTable
Dim Pg As Long, i As Long, n As Long, m As Long
Dim vSrc As Variant, vDest() As Variant
' setup query
Set shQuery = ActiveWorkbook.Sheets("Query")
Set shAllData = ActiveWorkbook.Sheets("AllData")
'Set qt = shQuery.QueryTables(1)
On Error Resume Next
Set qt = shQuery.QueryTables("Liebermans")
If Err.Number <> 0 Then
Err.Clear
Set qt = shQuery.QueryTables.Add( _
Connection:="URL;http://www.liebermans.net/productlist.aspx?id=7759&page=1", _
Destination:=shQuery.Cells(1, 1))
With qt
.Name = "Liebermans"
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End If
On Error GoTo 0
i = InStr(qt.Connection, "&page=")
' clear old data
shAllData.UsedRange.ClearContents
shAllData.Cells(1, 1) = "Title"
shAllData.Cells(1, 2) = "Artist"
shAllData.Cells(1, 3) = "Type"
shAllData.Cells(1, 4) = "Paper Size"
shAllData.Cells(1, 5) = "Image Size"
shAllData.Cells(1, 6) = "Price"
shAllData.Cells(1, 7) = "Quantity"
m = 0
ReDim vDest(1 To 10000, 1 To 7)
For Pg = 1 To 1
' Query Wb site
qt.Connection = Left(qt.Connection, i + 5) & Pg
qt.Refresh False
' Process data
vSrc = qt.ResultRange
n = 2
Do While n < UBound(vSrc, 1)
If vSrc(n, 1) <> "" And vSrc(n - 1, 1) = "" Then
m = m + 1
vDest(m, 1) = vSrc(n, 1)
End If
If vSrc(n, 1) Like "Artist:*" Then vDest(m, 2) = Trim(Mid(vSrc(n, 1), 8))
If vSrc(n, 1) Like "Type:*" Then vDest(m, 3) = Trim(Mid(vSrc(n, 1), 6))
If vSrc(n, 1) Like "Paper Size:*" Then vDest(m, 4) = Trim(Mid(vSrc(n, 1), 12))
If vSrc(n, 1) Like "Image Size:*" Then vDest(m, 5) = Trim(Mid(vSrc(n, 1), 12))
If vSrc(n, 1) Like "Retail Price:*" Then vDest(m, 6) = Trim(Mid(vSrc(n, 1), 14))
If vSrc(n, 1) Like "Quantity in stock:*" Then vDest(m, 7) = Trim(Mid(vSrc(n, 1), 19))
n = n + 1
Loop
Next
' Put data in sheet
shAllData.Cells(2, 1).Resize(m, 7) = vDest
End Sub

Resources