I am a beginner with VBA and am having a hard time building a table in PPT with excel data that includes merged cells. Currently, my code loops through my excel range and brings over rows of data (unmerged). I would like for my macro to loop through column B, identify rows that are merged, then for each set of merged rows, copy over the associate rows to a ppt table.
OR
Since my macro is already bringing over the rows, is there a way to go through each table in the slides and merge cells with the same value?
Current code:
Dim count i, j as integer: count = 3
Dim rng as Range
Dim PPRow as integer: Maxheight=380
SlideNo = SlideNo + 3
j = SlideNo
i=Application.WorksheetFunction.CountA(Sheets("Sheet1").Range("B10:B80"))
If i >= 1 Then
PPApp.ActiveWindow.View.GotoSlide SlideNo
For f = 1 To (i +1)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,1).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 0)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,2).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 1)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,3).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 2)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,4).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 3)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,5).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 4)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,6).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 5)
o = o +1
If row < i And PPPres.Slides(SlideNo).Shapes("tblTable1").Height > MaxHeight Then
Module2.InsertDuplicateSlide (SlideNo)
SlideNo = SlideNo + 1
PPApp.ActiveWindow.View.GotoSlide SlideNo
MaxHeight = 380
For Row2 = 3 To PPPres.Slides(SlideNo).Shapes("tblTable1").Table.Rows.Count
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.Rows(2).Delete
Next Row2
PPRow = 2
Else: PPPres.Slides(SlideNo).Shapes("tblTable1").Table.Rows.Add
PPRow = PPRow +1
End if
Next
End if
End Function
Thanks in advance
Related
The function is designed to take in input - variable pg - that is in a cell on the spreadsheet, go through the rows of data to see which row in a column 1 matches variable pg. Once the match is found, it then goes through the columns to see which of the columns has "VRP23" Or "VRP24" in the first row. When that is found, it takes the number of the matching row/column and performs the "step1" modification. The issue is that in the spreadsheet the error #VALUE! appears and I'm not sure why this is.
Function getECONpgdimscore1(pg As String) As Double
Dim row As Integer
row = 2
Dim c As Integer
c = 1
Dim econ As Double
econ = 0
Dim x As Integer
Dim NumRows As Integer
NumRows = Range("A2", Range("A2").End(xlDown)).rows.count
Cells(row, 1).Select
For x = 1 To NumRows
If Cells(row, 1).Value = pg Then
Do While c < 48
Cells(row, 7 + c).Select
If Cells(1, 7 + c).Value = ("VRP23" Or "VRP24") Then
econ = econ + step1(Cells(1, 7 + c), Cells(row, 7 + c))
End If
c = c + 1
Loop
End If
row = row + 1
Next x
getECONpgdimscore1 = (econ / 100) * 2.5
End Function
I am having some issues with my code any help would be greatly appreciated.
I have a range of data in a tab called Wheel Diameters and I need the following criteria to be met (Columns B6 to B28, G, L need to be less than 4000 and the cell values need to be 800 or less) the second is (Columns B35 to B54, G, L need to be more than 4000 but less than 5000 and the cell values need to be 800 or less) the third is (Columns B61 to B92, G, L need to be 9000 or greater and the cell values need to be 800 or less) for the information to be lifted into another tab called Wheel Diameters league.
The less than 4000 need to go into the wheel diameters league tab in columns A and B, the greater than 4000 but less than 5000 need to go into columns D and E, the greater than 9000 need to go into columns G and H.
Sub BUTTON5_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
'Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Wheel Diameters")
Set Target = ActiveWorkbook.Worksheets("Wheel Diameters League")
Target.Range("A2:B5000").Clear
j = 2 ' Start copying to row 2 in target sheet
For i = 1 To 3 'Number of ¿wees?
For Each c In Union(Source.Range(Cells(6, 5 * i - 2), Cells(28, 5 * i + 1)), Source.Range(Cells(35, 5 * i - 2), Cells(54, 5 * i + 1)), Source.Range(Cells(61, 5 * i - 2), Cells(92, 5 * i + 1)))
If c.Text < 4000 And c.Text <= 800 Then
Target.Cells(j, 1) = Source.Cells(c.Row, 5 * i - 3)
Target.Cells(j, 2) = Source.Cells(5, c.Column)
j = j + 1
ElseIf c.Text <= 800 And c.Text >= 4000 Then
Target.Cells(j, 4) = Source.Cells(c.Row, 5 * i - 3)
Target.Cells(j, 5) = Source.Cells(5, c.Column)
j = j + 1
End If
Next c
Next i
End Sub
Example of how it looks:
3405 - As it is greater than 800 the details Column 1 and 3405 will be lifted and copied into a second tab called 'Wheel Diameters League'
This works on your example data:
Dim Source As Worksheet
Dim Target As Worksheet
Dim rg As Range
Dim x As Long, y As Long, z As Long, tcol As Long, threshold As Long
Set Source = ActiveWorkbook.Worksheets("Wheel Diameters")
Set Target = ActiveWorkbook.Worksheets("Wheel Diameters League")
Set rg = Source.Range("B6:P92")
For x = 1 To rg.Columns.Count Step 5
For y = 1 To rg.Rows.Count
For z = 1 To 4
Select Case rg.Cells(y, x)
Case 0 To 3999
tcol = 2 ' column 'B'
threshold = 800
Case 4000 To 8999
tcol = 5 ' column 'E'
threshold = 864
Case Else
tcol = 8 ' column 'H'
threshold = 849
End Select
If rg.Cells(y, x + z) > 10 And rg.Cells(y, x + z) <= threshold Then
With Target.Cells(Rows.Count, tcol).End(xlUp)
.Offset(1, 0) = rg.Cells(y, x) 'write Coach No
.Offset(1, 1) = z 'write Axle No
.Offset(1, 2) = rg.Cells(y, x + z) 'write value
End With
End If
Next z
Next y
Next x
I've added a new variable called tcol, which is the target column we're writing the league data to. I've created a Select Case to decide what column it's set to, based on the axle class.
I've added threshold which is also based on axle class.
I've expanded the range down to P92 to read ALL the data.
I've added a test to ensure the value is above 10, not just below threshold. This prevents cells that are not axle data, but are axle headings from triggering the writing to the league table.
I've made the For.. Next loops for x and y more dynamic, in case your tables change size - in which case you just need to alter the rg range.
Lastly, I've added in the writing of the value to the table, as I hadn't noticed that requirement before.
I have an excel 2007 sheet where column names with data are all placed in one single column and I need to shift one column name to the left or right with data so that I can have separate columns. Can you create a VBA function where it reads all rows of the column and shift those columns with certain keywords. Such as:
A1 B1
1 **Category1**
Cat1 info here
**cf**
45
34
34
Sf
542
234
234
2 **Category2**
Cat2 info here
**cf**
76
23
67
**Sf**
678
987
3476
I Need to move "cf" column + data to a different column and paste it to its relevant category. So "cf" would shift right with data and move up along with its category. I would then delete the empty rows of B Column.
Finally had it figured out, Bad coding maybe but it works.. :)
Thanks All for your Help .
Sub test()
Dim i As Long
Dim toprow As Long
Dim z As Long
Dim count As Long
Dim b As Long
toprow = 3
b = toprow
For i = toprow To Cells(Rows.count, 1).End(xlUp).Row
If Not Cells(i, 1) = "" And Not Cells(i, 2) = "" Then
b = i
count = 0
z = i
End If
If Cells(i, 1) = "" Then
If Cells(i + 1, 1) = "" Then
z = i
If Not Cells(z + 1, 2) = "" Then
Cells(z + 1, 2).Cut Cells(b, 2)
i = b
b = z + 1
count = 0
ElseIf count = 0 Then
count = z
b = count
End If
End If
End If
Next i
End Sub
I'm trying to automate the generation of a dynamic XYscatter chart using VBA. My data are in sets of 12 individual data per trial and the number of trial will vary. Firstly by scanning the csv file to locate the last set of data, and by removing the first line of the tag, i divided it by 12 to determine the number of sets available and then populate the data into to graph with the corresponding data points and series name. I've got most of the code working but I'm having some syntax issue on including a range data for series name. The series name will only work if I am selecting a column instead of a range of column data.
How can I modify my code to have multiple column input as my Series Name?
Sub PlotSelect()
Dim myChart As Chart
DataRow = 1
SelectRow = 2
With ActiveSheet
'To count the number of rows to determine number of sets of data
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Row = LastRow - 1
N = Row / 12
'Creating a dummy chart before repopulating the data points
Range("A1:B2").Select
Set myChart = ActiveSheet.Shapes.AddChart2(240, xlXYScatterSmooth).Chart
' delete all the dummy series
For i = myChart.SeriesCollection.Count To 1 Step -1
myChart.SeriesCollection(i).Delete
Next
'Populating chart with data
Do While DataRow <= N
If DataRow <> -1 Then
myChart.SeriesCollection.NewSeries
myChart.SeriesCollection(DataRow).Name = Range(ActiveSheet.Cells(SelectRow, 2), ActiveSheet.Cells(SelectRow, 5))
myChart.SeriesCollection(DataRow).Values = Range(ActiveSheet.Cells(SelectRow, 9), ActiveSheet.Cells(SelectRow + 11, 9))
myChart.SeriesCollection(DataRow).XValues = Range(ActiveSheet.Cells(SelectRow, 8), ActiveSheet.Cells(SelectRow + 11, 8))
End If
DataRow = DataRow + 1
SelectRow = SelectRow + 12
Loop
End Sub
Instead of using a range of cells to generate the Name for the data entry, I merge the data in the cells and copy the content into another cell and select the new cell with the concatenated cells. Later i delete the temporary cell.
Do While DataRow <= 2
If DataRow <> -1 Then
myChart.SeriesCollection.NewSeries 'To add new data entries
**Range("B9999").Select
ActiveCell.FormulaR1C1 = ((Cells(SelectRow, 4)) & "_" & (Cells(SelectRow, 5)) & "_" & (Cells(SelectRow, 6)))
myChart.FullSeriesCollection(DataRow).Name = Range("B9999")**
myChart.SeriesCollection(DataRow).Values = Range(Cells(SelectRow, 2), ActiveSheet.Cells(SelectRow + 600, 2))
myChart.SeriesCollection(DataRow).XValues = Range(Cells(SelectRow, 1), ActiveSheet.Cells(SelectRow + 600, 1))
End If
DataRow = DataRow + 1
SelectRow = SelectRow + 601
Loop
Range("B9999").Delete 'to delete temp data
ActiveWindow.ScrollRow = 2 'to reset spreadsheet view
The modifications are located in the ** ** range
First time poster and new to programming in general. I have a project in which i have to build a financial model to mine for data in excel. I have succeeded in building said model on VBA. I have ran tests on 3,000 line dataset and it was successful. I will briefly explain what it does.
I track a given stock on a given day on multiple exchanges. I download the data (roughly 935,000 lines) The first step is copy all the data for a given exchange (roughly 290,000) onto a new sheet (this takes roughly 8min), then I create a new column to log the bid ask spread (12secs), the next step is what Im having trouble with, I basically rank each line of data twice, one column for Bid size and one column for Ask size. I created a function which uses excel Percentile function and ranks based on where the given bid and ask size lands. As of right now, I have been running the Macro for the last 35min and has yet to execute. I cant attempt the other macros since each macro depends on the previous one.
So my basic issue is that since my data set is large, my model keeps crashing.The code seems to be fine when working with the test data, and it doesn't throw any errors when I run the program, but with the larger data set it just crashes. Does anyone have any suggestions? Is this normal with such large amounts of data?
Thanks in advance.
Sham
Here is the sub and function thats giving me the trouble, the sub takes in the required inputs to run the function and then pops into the assigned cell. The code is suppose to repeat the process for three separate sheets. For now, Id like it to work on one sheet, hence used the comments to not include the loop
Sub Bucketting()
Dim firstRow As Long
Dim lastRow As Long
Dim counter As Long
Dim bidRange As Range
Dim offerRange As Range
Dim bidScroll As Range
Dim offerScroll As Range
Dim Ex As String
Dim i As Integer
'For i = 1 To 1 Step 1 'Sheet Selection Process
' If i = 1 Then
' Ex = "Z"
' ElseIf i = 2 Then
' Ex = "P"
' Else
' Ex = "T"
' End If
Sheets("Z").Select 'Sheet selected
With ActiveSheet
firstRow = .UsedRange.Cells(1).Row + 1
lastRow = .UsedRange.Rows.Count
Set bidRange = .Range("F2:F" & lastRow)
Set offerRange = .Range("G2:G" & lastRow)
For counter = lastRow To firstRow Step -1
Set bidScroll = .Range("F" & counter)
Set offerScroll = .Range("G" & counter)
With .Cells(counter, "J")
.Value = DECILE_RANK(bidRange, bidScroll)
End With
With .Cells(counter, "K")
.Value = DECILE_RANK(offerRange, offerScroll)
End With
Next counter
End With
Range("J1").Select
ActiveCell = "Bid Rank"
ActiveCell.Offset(0, 1) = "Offer Rank"
'Next i
End Sub
Function DECILE_RANK(DataRange, RefCell)
'Credit: BJRaid
'DECILE_RANK(The Range of data)
'Declares the function that can be called in the spreadsheet cell - enter '=DECILE_RANK(A5:A50,A5)
'Using the percentile worksheet function calculate where the 10th, 20th etc percentile of the reference range are
DEC1 = Application.WorksheetFunction.Percentile(DataRange, 0.1)
DEC2 = Application.WorksheetFunction.Percentile(DataRange, 0.2)
DEC3 = Application.WorksheetFunction.Percentile(DataRange, 0.3)
DEC4 = Application.WorksheetFunction.Percentile(DataRange, 0.4)
DEC5 = Application.WorksheetFunction.Percentile(DataRange, 0.5)
DEC6 = Application.WorksheetFunction.Percentile(DataRange, 0.6)
DEC7 = Application.WorksheetFunction.Percentile(DataRange, 0.7)
DEC8 = Application.WorksheetFunction.Percentile(DataRange, 0.8)
DEC9 = Application.WorksheetFunction.Percentile(DataRange, 0.9)
' Calculate the Decile rank that the reference cell value sits within
If (RefCell <= DEC1) Then DECILE_RANK = 1
If (RefCell > DEC1) And (RefCell <= DEC2) Then DECILE_RANK = 2
If (RefCell > DEC2) And (RefCell <= DEC3) Then DECILE_RANK = 3
If (RefCell > DEC3) And (RefCell <= DEC4) Then DECILE_RANK = 4
If (RefCell > DEC4) And (RefCell <= DEC5) Then DECILE_RANK = 5
If (RefCell > DEC5) And (RefCell <= DEC6) Then DECILE_RANK = 6
If (RefCell > DEC6) And (RefCell <= DEC7) Then DECILE_RANK = 7
If (RefCell > DEC7) And (RefCell <= DEC8) Then DECILE_RANK = 8
If (RefCell > DEC8) And (RefCell <= DEC9) Then DECILE_RANK = 9
If (RefCell > DEC9) Then DECILE_RANK = 10
End Function
935,000 lines is a lot for excel. Like, really a lot. Barring saying using a real database, If your application is literally putting a =Percentile(...) in each cell, I would recommend Trying to use another tool for that. Perhaps something within VBA itself. More generally, use something outside of a cell - then store the result value in the cell. There is a lot of overhead in maintaining those formulas that are interdependent on 935k rows of data.
The problem is that your looping through each row individually, the Excel way is to try and work with whole ranges at once whenever possible. I would load the ranges into arrays, then modify your DECILE_RANK code to work with the items in the array.
Note that variant arrays that read ranges in are 2-D.
Here is the fully functioning code including my custom VBA array slicer. Note that it was only tested on a small dataset:
Sub Bucketting()
Dim lastRow As Long
Dim bidArray As Variant
Dim offerArray As Variant
Sheets("Sheet1").Select 'Sheet selected
With ActiveSheet
lastRow = .UsedRange.Rows.Count + 1
bidArray = .Range("F2:F" & lastRow)
offerArray = .Range("G2:G" & lastRow)
Range("J2:J" & lastRow).Value = GetArraySlice2D(DECILE_RANK(bidArray), "column", 1, 1, 0)
Range("K2:K" & lastRow).Value = GetArraySlice2D(DECILE_RANK(offerArray), "column", 1, 1, 0)
End With
Range("J1").Select
ActiveCell = "Bid Rank"
ActiveCell.Offset(0, 1) = "Offer Rank"
End Sub
Function DECILE_RANK(DataRange As Variant) As Variant
' Credit: BJRaid
' DECILE_RANK(The Range of data)
' Declares the function that can be called in the spreadsheet cell - enter '=DECILE_RANK(A5:A50,A5)
Dim DEC(0 To 10) As Variant
Dim i As Integer, j As Integer
'Using the percentile worksheet function calculate where the 10th, 20th etc percentile of the reference range are
DEC(0) = 0
For i = 1 To 9
DEC(i) = Application.WorksheetFunction.Percentile(DataRange, 0.1 * i)
Next i
DEC(10) = Application.WorksheetFunction.Max(DataRange)
' Calculate the Decile rank that the reference cell value sits within
For i = 1 To UBound(DataRange, 1)
For j = 1 To 10
If ((DataRange(i, 1) > DEC(j - 1)) And (DataRange(i, 1) <= DEC(j))) Then
DataRange(i, 1) = j
Exit For
End If
Next j
Next i
DECILE_RANK = DataRange
End Function
Public Function GetArraySlice2D(Sarray As Variant, Stype As String, Sindex As Integer, Sstart As Integer, Sfinish As Integer) As Variant
' this function returns a slice of an array, Stype is either row or column
' Sstart is beginning of slice, Sfinish is end of slice (Sfinish = 0 means entire
' row or column is taken), Sindex is the row or column to be sliced (NOTE:
' 1 is always the first row or first column)
' an Sindex value of 0 means that the array is one dimensional 3/20/09 Lance Roberts
Dim vtemp() As Variant
Dim i As Integer
On Err GoTo ErrHandler
Select Case Sindex
Case 0
If Sfinish - Sstart = UBound(Sarray) - LBound(Sarray) Then
vtemp = Sarray
Else
ReDim vtemp(1 To Sfinish - Sstart + 1)
For i = 1 To Sfinish - Sstart + 1
vtemp(i) = Sarray(i + Sstart - 1)
Next i
End If
Case Else
Select Case Stype
Case "row"
If Sfinish = 0 Or (Sstart = LBound(Sarray, 2) And Sfinish = UBound(Sarray, 2)) Then
vtemp = Application.WorksheetFunction.Index(Sarray, Sindex, 0)
Else
ReDim vtemp(1 To Sfinish - Sstart + 1)
For i = 1 To Sfinish - Sstart + 1
vtemp(i) = Sarray(Sindex, i + Sstart - 1)
Next i
End If
Case "column"
If Sfinish = 0 Or (Sstart = LBound(Sarray, 1) And Sfinish = UBound(Sarray, 1)) Then
vtemp = Application.WorksheetFunction.Index(Sarray, 0, Sindex)
Else
ReDim vtemp(1 To Sfinish - Sstart + 1)
For i = 1 To Sfinish - Sstart + 1
vtemp(i) = Sarray(i + Sstart - 1, Sindex)
Next i
End If
End Select
End Select
GetArraySlice2D = vtemp
Exit Function
ErrHandler:
Dim M As Integer
M = MsgBox("Bad Array Input", vbOKOnly, "GetArraySlice2D")
End Function
I'm not sure if this will directly address your problem, but have you considered using Application.ScreenUpdating = False? Don't forget to set it back to true once your data has processed.