The program I am working on involves reading and determining the difference between i - (i+1) and i-(i-1) from excel.
If the difference exceeds 4 then the program deletes the row at i.
The program works well at the first try. Suddenly, it says that "You can not change part of an Array".
Option Explicit
Sub Data_Delet()
Dim a As Double, b As Double, c As Double, i As Double
Dim rkill As Range
' a,b, and c are used as steps in order to proceed to the next data points
a = 18
b = 0
c = 0
With ThisWorkbook.Worksheets("Sheet1")
' The second do loop delete data points that does not follow the requirements
Do
If Abs(.Cells(a - 1, 2) - .Cells(a, 2)) > 4 And Abs(.Cells(a, 2) - .Cells(a + 1, 2)) > 4 Then
If rkill Is Nothing Then
Set rkill = Rows(a)
Else
Set rkill = Union(rkill, Rows(a))
End If
End If
a = a + 1
Loop Until .Cells(a, 2).Value = ""
If Not rkill Is Nothing Then rkill.EntireRow.Delete
' The third Do loop determines the number of data points that are still present after deleting the data points
Do
i = .Cells(17 + c, 1)
c = c + 1
Loop Until .Cells(17 + c, 1).Value = ""
' The if statment determine whether or not the number data points from before are the same after deletion process
If b = c Then
.Cells(2, 5) = "N"
Else
.Cells(2, 5) = "Y"
End If
' c is the number of data point after deletion
.Cells(12, 5) = c
End With
End Sub
The error "You cannot change part of an array" on rkill.EntireRow.Delete means that the row you want to delete is intersecting a range referenced in an array formula (a formula with braces).
Excel does not allow this. One way would be to remove the offending array formula(s) at the start of your code, and redefine it/them again at the end of your code. Or find a solution to turn these array formulas into normal formulas.
Related
I have the need to automatic create report that is based on the dates and portfolios.
For example if I put 2 dates and 2 portfolios like this
The report should look like this:
So if we enter 3 dates and 4 portfolios the report should have 3 tables and each one has 4 portfolios...
I'm ok to do it manual but it is ideally to be automatic,(I think it can be done through VBA, but not quite sure about it) can you guys help? Thank you.
You have to to move your data from where is stored to the Project sheet.
I guess that the date doesn't make any different on the portfolio, isn't it?
If so, it's quite easy. I don't know how your data is stored, but let's guess it's equal as shown it your screenshot.
Option Base 1 'array will start at 1 instead of 0
Public Setting As Worksheet, ListPortfolios As Worksheet, Project As Worksheet
Public RangeSelectDates As Range, RangeSelectPortfolios As Range, RowOfCodePortfolios As Range
Public ArraySelectDates(), ArraySelectPortfolios(), ArrayOfCodePortfolios(), ArrayPortfolio(), ArrayProject()
Public PortfolioCode$
Dim i%, j%, k%, r%, c%
Sub Automate()
Set Setting = Worksheets("Setting")
Set ListPortfolios = Worksheets("ListPortfolios")
Set Project = Worksheets("Project")
'First, read the portfolio code and dates to import and store in array
With Setting
Set RangeSelectDates = .Cells(4, 5).CurrentRegion
Set RangeSelectPortfolios = .Cells(4, 8).CurrentRegion
End With
ArraySelectDates = RangeSelectDates
ArraySelectPortfolios = RangeSelectPortfolios 'store the range in a Array
ReDim ArrayProject(1 To 24, 1 To 1)
'Now, create an array with the names of the portfolios where you have stored them. I don't know how your data is stored.
'I assume you've got it as the Project sheet result it's shown and also at "ListPortfolios" sheet
With ListPortfolios
Set RowOfCodePortfolios = .Rows(5)
End With
ArrayOfCodePortfolios = RowOfCodePortfolios 'store the row in a Array
k = 0 'means no value is found
For i = LBound(ArraySelectPortfolios) To UBound(ArraySelectPortfolios) 'Navigate to all the Portfolios Selected
'the portfolio codes are stored in the "second column" of the array, say PortfolioCode is the name of the portfolio
PortfolioCode = ArraySelectPortfolios(i, 2)
For j = LBound(Application.Transpose(ArrayOfCodePortfolios)) To UBound(Application.Transpose(ArrayOfCodePortfolios)) 'now navigate to where your portfolios are stored
If ArrayOfCodePortfolios(1, j) = PortfolioCode Then 'if match, create a new array with the whole portfolio
With ListPortfolios
ArrayPortfolio = .Range(.Cells(1, j), .Cells(24, j + 2)) 'I don't know the size of your data. I assume that the first column is the same of where the portfoliocode is stored and its size is 24 rows x 3 columns
End With
'now, copy it to the Project Portfolio
ReDim Preserve ArrayProject(1 To 24, 1 To 3 + k * 3)
For r = 1 To 24 'from the r (row) one to 24th. I don't know how your data is stored
For c = 1 To 3 'from the column 1 to the 3rd of each portfolio
ArrayProject(r, c + k * 3) = ArrayPortfolio(r, c) 'built the result for each portfolio found
Next c
Next r
k = k + 1 'one value is found, let's go for the next one if so
End If
Next j
Next i
If k <> 0 Then 'if any value is found then
For i = 1 To UBound(ArraySelectDates) 'let's place the date and print to the excel
ArrayProject(2, 1) = ArraySelectDates(i, 2) 'paste the date into the array
With Project
.Range(.Cells(1, 4 + 1 + (i - 1) * k), .Cells(24, UBound(Application.Transpose(ArrayProject)) + 3 + (i - 1) * k)) = ArrayProject 'print the array
'1+(i-1)*k is the first column + which date are we copying times portfolio codes found
End With
Next i
End If
End Sub
There's no error handling, either if there aren't input values may crash. But first, make it work
I have a code that searches an excel fill for the word distance, takes the value of the cell next to it, paste it into a new cell, then sums all the cells up. Which works great, but i now need to find a way to only sum ever even row number. Does that make sense?
Sub Distance_Check()
Dim DistanceCheck As String
Dim DistanceNumber As String
Dim DistanceSum As String
Dim DistanceTotal As String
DistanceCheck = MsgBox("Would you like to check the distance?", vbYesNo)
If DistanceCheck = vbYes Then
If IsArray(fname) Then Workbooks.OpenText fname(1)
i = 1
findStr = "Distance"
Set foundCel = Range("A:A").Find(what:=findStr)
If Not foundCel Is Nothing Then
firstAddress = foundCel.Address
Do
Range("J" & i).Value = foundCel.Offset(0, 1).Value
Set foundCel = Range("A:A").FindNext(foundCel)
i = i + 1
Loop While Not foundCel Is Nothing And foundCel.Address <> firstAddress
End If
Set wkbSourceBook = ActiveWorkbook
DistanceNumber = i - 2
DistanceSum = WorksheetFunction.Sum(Range(Cells(2, 15), (Cells(DistanceNumber + 1, 15))))
DistanceTotal = DistanceSum / DistanceNumber
If DistanceNumber = Cells(2, 12) Then
MsgBox ("No error found wihin distance")
Else
MsgBox ("Error found with distance")
End If
Else
End If
Call Save_Data
End Sub
Would the way youd go about this be using a for loop on the
cells(DistanceNumber(j,+1)
Where j = 0,
j = j +2 ,
Until j > DistanceNumber,
Would that work? If so how would you go about it?
Thanks
A quick way to step through a loop in the desired increments is to use the Mod operator which divides two numbers and returns any remainder (e.g. 7 mod 2 = 1, as two sixes fit into seven, leaving one).
You can use the row property of the range you identify with the Find method, and since you want to jump by two the modulo should be zero:
If foundcel.Row Mod 2 = 0 Then Range("J" & i).value = foundcel.Offset(0, 1).Value
That said, there is a 'built in' way to step through a loop if using a For loop like this
For x = 2 to 10 Step 2
' Do stuff
Next x
You can also use this method to step backwards, e.g.
For x = 100 to 0 Step -10
' Do stuff backwards!
Next x
I have a shared excel sheet with records being entered all the time. I want to find the last consecutive entry of a specific Name(its 'A' in this example) and record the value at the begining and ending of last occurance.
The output of the attached excel should be
A,2,34 ---when i open when there were 5 entries
A,5,null ---when i opened when there were 9 entries
A,9,6 ---when i opened when there were 11 entries
A,9,3 ---when i opened when there were 12 entries
please help me with the formula that i can use in a different tab of same excel.
Thanks
this should work.
in column C use this formula. Works from row2 and down. row1 should be irrelevant (no consecutive entries at this point).
=IF(B1=B2,B2&","&A1&","&A2,"")
You can also have a formula display whatever is the last entry for that value. This is for value "A".
=LOOKUP(2,1/(B:B=E1),C:C)
A UDF should be able to handle the relative loop.
Option Explicit
Function LastConColVals(rng As Range, crit As String, _
Optional delim As String = ",")
Dim tmp As Variant, r As Long, rr As Long
'allow full column references
Set rng = Intersect(rng, rng.Parent.UsedRange)
With rng
tmp = Array(crit, vbNullString, vbNullString)
For r = .Rows.Count To 1 Step -1
If .Cells(r, 2).Value = crit Then
tmp(2) = .Cells(r, 1).Value
For rr = r To 1 Step -1
If .Cells(rr, 2).Value = crit Then
tmp(1) = .Cells(rr, 1).Value
Else
Exit For
End If
Next rr
'option 1 - null last value for singles
If rr = (r - 1) Then tmp(2) = "null"
'option 2 - truncate off last value for singles
'If rr = (r - 1) Then ReDim Preserve tmp(UBound(tmp) - 1)
Exit For
End If
Next r
End With
LastConColVals = Join(tmp, delim)
End Function
I need some help with some VBA. The code below sorts a bunch of data which is spread horrizonally then apends them vertically which I have posted below:
Sub Test()
Application.ScreenUpdating = False
countrow = ActiveSheet.UsedRange.Rows.Count
countcolumn = ActiveSheet.UsedRange.Columns.Count
numberofiterations = countcolumn / 6
MsgBox "Number of Rows is" & Str(countrow)
MsgBox "Number of Column is" & Str(countcolumn)
ActiveSheet.Select
a = 1
b = 1
c = 6
d = 1
While n < numberofiterations
Range(Cells(a, b), Cells(countrow, c)).Select
Selection.Copy
Sheets(2).Select
ActiveSheet.Cells(d, 1).Select
Sheets(2).Paste
Sheets(1).Select
b = b + 6
c = c + 6
d = d + countrow
n = n + 1
Wend
End Sub
It runs ok once but when running it for the second time it itteraits through to the line:
While n < numberofiterations
I can't find the reason why it drops out the loop the second time. Any help will be apriciated
Thanks,
A few things to consider:
1) Please initialize the value of n. That is, before you start your loop, set
n = 0
explicitly. If you later add other code that happens to set n to some value, you will not get the result you expect
2) When you say
countrow = ActiveSheet.UsedRange.Rows.Count
Range(Cells(a, b), Cells(countrow, c)).Select
You will not get a selection all the way to the bottom of the range IF THE USED RANGE DIDN'T START IN ROW 1. If UsedRange = $Q1:Z20, then UsedRange.Rows.Count = 10, not 26!
This second point is probably not your problem today - but I wanted to point it out as it will bite you another time.
3) I am a huge fan of writing
Option Explicit
at the top of every module. It forces you to be thoughtful about every variable you create, and more likely will make you remember to initialize variables as well. In general it's good practice, and should be right up there on your list with "initialize right before you use".
I have a 2 columns that look like:
field group1
a 1.2
b 0.2
c 2.4
field group2
a 0.2
c 0.8
field group3
c 0.6
d 0.8
and so forth. I have been pondering about this for a while but can't seem to find a good way.
Is there a efficient way to make the dataset look like:
field group1 group2 group3
a 1.2 0.2
b 0.2
c 2.4 0.8 0.6
d 0.8
and so forth. Any help or idea?
For a one-off, you can probably do it just with formulae to identify which groups a row is in and then pivot, as described by others in the comments to your question.
However, for repeated use / less hassle the below should work.
This works on your test data and outputs on a new sheet according to your desired output in the question.
It works in memory so it should have good performance when scaled up to thousands of cells.
Sub blah()
'Declarations
Dim outWs As Worksheet
Dim inArr, outArr
Dim vector(), groups()
Dim outC As Collection
Dim currentGroup As Long
Dim i As Long, j As Long
Dim key
'load data
inArr = Selection.Value
Set outC = New Collection
'iterate through
For i = LBound(inArr, 1) To UBound(inArr, 1)
If inArr(i, LBound(inArr, 2)) Like "field*" Then 'new group
currentGroup = currentGroup + 1
ReDim Preserve groups(1 To currentGroup)
groups(currentGroup) = inArr(i, LBound(inArr, 2) + 1) 'assign group name
Else 'is a record/field
key = inArr(i, LBound(inArr, 2))
'retrieve existing, ignoring the exception thrown if key does not exist
On Error Resume Next
vector = outC(key)
If Err.Number = 5 Then 'error raised when key does not exist
ReDim vector(0 To currentGroup)
vector(0) = key 'add key
Else
outC.Remove (key) 'the reference of item is immutable so we must remove and add again
ReDim Preserve vector(0 To currentGroup) 'resize vector
End If
On Error GoTo 0
vector(currentGroup) = inArr(i, LBound(inArr, 2) + 1) 'assign value to current group in vector
outC.Add vector, key 'add to results
Erase vector
End If
Next i
'Process our results collection into an array suitable for dumping to a sheet
ReDim outArr(1 To outC.Count, 1 To currentGroup + 1)
For i = 1 To outC.Count
For j = 0 To UBound(outC(i))
outArr(i, j + LBound(outArr, 2) - LBound(outC(i))) = outC(i)(j)
Next j
Next i
'dump data
With ActiveWorkbook.Worksheets.Add
.Range(.Cells(1, 2), .Cells(1, 1 + UBound(groups))).Value = groups
.Range(.Cells(2, 1), .Cells(1 + UBound(outArr, 1), UBound(outArr, 2))).Value = outArr
End With
Exit Sub
End Sub
I hope that helps.
so i have an idea, its not beautiful but it will probably work...
copy your whole field column and paste it to a fresh sheet, use data tab and hit remove duplicates, if you transpose that so your top row is Field, a, b, c, d you can drop a formula thats something like this (untested) "=INDEX(Sheet1!B:B, MATCH($B$1,Sheet1!A1:A3,0))"
the search range in match is intentionally small and left without $ to that if you drag this formula down it will search a little further(A2:A4,A3:A5,etc) once you get all of them just find/replace all the N/As remove blanks and your good
if i have time i will try and put together a little macro that would be a lot cleaner...
In outline: Create a copy of your group1 column, filter it for values greater than 0 and delete these. Fill the blanks with the respective groups and then pivot.
i would rearrange data first, with a macro, this way:
Sub sa()
For Each cl In Range("B2:B1000").Cells
If IsNumeric(cl.Value) And Not IsEmpty(cl.Value) Then
If Not IsNumeric(cl.Offset(-1, 0).Value) Then
cl.Offset(0, 1).Value = cl.Offset(-1, 0).Value
Else
cl.Offset(0, 1).Value = cl.Offset(-1, 1).Value
End If
End If
Next
End Sub
such that data would be rearranged with this column assignment:
[field] [value] [group]
then it would be easy to do what you want, just create a pivot table... tell me in the commentaries if in need of further help...