can someone please look into my code and say me where is the mistake cause I got a type mismatch error message ? With this code I would like to delete all rows who which contain "0" in the respective cells.
I got the error message for the line where is standing: sn = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "|")), [transpose(row(1:8))])
Also I had to declare the variable "c00" and I choosed "c00 As Variant". I don't know if it its correct. I would appreciate someone helping me to solve the problem.
Dim sn As Variant, c00 As Variant
sn = Sheets(1).UsedRange
For j = 1 To UBound(sn)
If sn(j, 4) & sn(j, 5) & sn(j, 6) & sn(j, 7) & sn(j, 8) & sn(j, 9) = "000000" Then c00 = c00 & "|" & j
Next
If c00 <> "" Then
sn = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "|")), [transpose(row(1:8))])
Sheets(1).UsedRange.ClearContents
Sheets(1).Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End If
Original Code
Dim LR%
LR = Cells(Rows.Count, 3).End(xlUp).Row
Set Myrange = Range("D2:AO" & LR).SpecialCells(xlCellTypeBlanks) 'nur Leerzellen
Myrange.Formula = "0"
ActiveSheet.UsedRange
Set r = ActiveSheet.UsedRange
lastrow3 = r.Rows.Count + r.Row - 1
For j = lastrow3 To 1 Step -1
If (Cells(j, 4) = 0 And Cells(j, 5) = 0 And Cells(j, 6) = 0 And Cells(j, 7) = 0 And Cells(j, 8) = 0 And Cells(j, 9) = 0) Then
Rows(j).Delete
End If
Next j
Image w/ Error
Edit: the error was from attempting to use Application.Index on an array larger than the function size limit. Redirect to here for Q&A an on alternative option to Application.Index.
I'll break down my analysis of your code:
Application.Index(Array, Row_Number, Column_Number)
The code you currently have:
sn = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "|")), [transpose(row(1:8))])
is saying that the parameters are:
Array: sn
Row_Number: Application.Transpose(Split(Mid(c00, 2), "|"))
Column_Number: [transpose(row(1:8))]
The Array section looks fine to me. The Row numbers will, I think(?), be the values for j which you collected in c00 (although the Application.Transpose may not be necessary Correction: it is in this scenario.). I have no idea what is going on with your Column_Number parameter....
Issues:
Application.Index keeps the selected columns/rows. However, your if statement selects the values of j where the rows are entirely 0, so instead of losing them, you would be keeping only those rows.
If your intention is to keep all the columns, you can just input 0 into the Column_Number parameter. Correction: this works when only selecting a single row to keep. If selecting multiple rows, all columns must be listed as well.
Corrected code:
Since this code does delete data, you should save a copy of the data before running this code on it.
Note: c00 can be a Variant; String also works. You will need to also copy over the fillA function, as well.
Dim sn As Variant, c00 As String
sn = Sheets(1).UsedRange
' Changed condition based on your post with previous code. (And negated)
For j = 1 To UBound(sn)
If Not ((Cells(j, 4) = 0 And Cells(j, 5) = 0 And Cells(j, 6) = 0 And Cells(j, 7) = 0 And Cells(j, 8) = 0 And Cells(j, 9) = 0)) Then c00 = c00 & "|" & j
Next
If c00 <> "" Then
' Corrected inputs for Application.Index, Added helper function "fillA".
sn = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "|")), fillA(1, UBound(sn, 2) - LBound(sn, 2) + 1))
Sheets(1).UsedRange.ClearContents
Sheets(1).Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End If
Function fillA(min As Long, max As Long) As Variant
Dim var() As Variant, i As Long
ReDim var(1 To max - min + 1)
For i = min To max
var(i) = i + min - 1
Next i
fillA = var
End Function
Edit:
Realized this did not address your issue. I suspect that the error was from the [transpose(row(1:8))] you were inserting for the Column_Number parameter.
Maybe someone else has a simpler way of doing what I did with the fillA function (what I believe you were attempting).
Related
I have two rows of data, fracture pressure and depth. I have to code in vba to generate the polynomial (quadratic for this case) equation and then output the coefficients to the worksheet. I am using Linest and Index. For this two rows of data, I don't know how many datasets I have because I need to delete some noisy data first (the definition of noisy data is randomly so the number of datasets vary each time), so I can't use something like "A17:A80" in the linest function. However, it looks like the worksheet function in vba can't work for arrays.
Dim Frac_x, Frac_y As Range
Dim X
Set Frac_x = Range(Cells(17, 1), Cells(e - 1, 1))
Set Frac_y = Range(Cells(17, 7), Cells(e - 1, 7))
X= Application.WorksheetFunction.LinEst(Frac_y,Frac_x,{1,2})
Cells(3, 8).Value = Application.WorksheetFunction.Index(X, 1, 1)
Cells(4, 8).Value = Application.WorksheetFunction.Index(X, 1, 2)
Cells(5, 8).Value = Application.WorksheetFunction.Index(X, 1, 3)
In this code, e is defined in the previous code, (e-1) represents the total number of datasets. However, I keep getting { is a invalid character for the line: X= Application.WorksheetFunction.LinEst(Frac_y,Frac_x,{1,2})
Then I did some researches and modified the code to:
Dim Frac_x, Frac_y As Range
Dim X
Set Frac_x = Range(Cells(17, 1), Cells(e - 1, 1))
Set Frac_y = Range(Cells(17, 7), Cells(e - 1, 7))
X = Application.Evaluate("=linest(" & Frac_y & "," & Frac_x & "^ {1,2}))")
Cells(3, 8).Value = Application.WorksheetFunction.Index(X, 1, 1)
Cells(4, 8).Value = Application.WorksheetFunction.Index(X, 1, 2)
Cells(5, 8).Value = Application.WorksheetFunction.Index(X, 1, 3)
Then I keep getting Type Dismatch error for the line:
X = Application.Evaluate("=linest(" & Frac_y & "," & Frac_x & "^ {1,2}))")
I am sure the two ranges frac_y and frac_x their type matches. Anyone could help?
You are right, that Excel VBA can't do things like arrVariable^{1,2}. That must be done with loops over the array items.
But the Evaluate approach should work. But your formula string is not correct. To detect and avoid such incorrectness, I will ever concatenate such formula strings within a String variable first. Then I can simply check the variable's value.
Example, Values are in A17:A26 and G17:G26:
Sub test()
Dim Frac_x As Range, Frac_y As Range
Dim X
e = 27
With ActiveSheet
Set Frac_x = .Range(.Cells(17, 1), .Cells(e - 1, 1))
Set Frac_y = .Range(.Cells(17, 7), .Cells(e - 1, 7))
arrX = Frac_x
ReDim arrX2(1 To UBound(arrX), 1 To 2) As Double
For i = LBound(arrX) To UBound(arrX)
arrX2(i, 1) = arrX(i, 1)
arrX2(i, 2) = arrX(i, 1) * arrX(i, 1)
Next
X = Application.LinEst(Frac_y, arrX2)
'sFormula = "=LINEST(" & Frac_y.Address & "," & Frac_x.Address & "^{1,2})"
'X = Application.Evaluate(sFormula)
.Range(.Cells(3, 8), .Cells(5, 8)).Value = Application.Transpose(X)
End With
End Sub
Hints: Use Application.LinEst instead of Application.WorksheetFunction.LinEst. The latter will throw an error if the function cannot work while the first will return an error value instead. So the first will not interrupt the program as the latter will do.
I'm attempting to transform a large Excel input table into a custom format, also as an Excel table. Visually this is what I need to accomplish:
The psuedo-code I've come up with to solve the problem goes as follows:
Pseudo code:
// Column A is of higher level than column B
Initialize dictionary
Read the entire spreadsheet into system memory
While(sheet has records) {
Loop through spreadsheet records top-down
Start at cell A1
Look to the immediate right of column A
if(A:B not already in dictionary){
Dictionary>> Append B as child of A in dictionary // Must find correct entry and append value
}
Move to cell A+1
}
Once sheet is out of records {
Move one column to the right
Repeat while method
Do this until entire column is null
}
while (dictionary has records) {
Key = Column A value
List of values = Column B value
Save values as new Excel sheet
}
end
I'm not sure if there are libraries that exist that would accomplish what I need here, I can use whatever language offers a solution.
Appreciate any input from you all.
Stuff the 'Raw Data' into a two dimensional variant array and cycle through each rank, building the children of the parent or sub-parent as the case may be.
Sub collate_family_values()
Dim v As Long, w As Long, vVALs As Variant
Dim sPAR As String, sTMP As String
With ActiveSheet '<-set this worksheet reference properly!
.Columns("f:g").EntireColumn.Delete
.Cells(1, 6) = "Output Data"
.Cells(2, 6).Resize(1, 2) = .Cells(2, 1).Resize(1, 2).Value
vVALs = Application.Transpose(.Range(.Cells(3, 1), .Cells(Rows.Count, 4).End(xlUp)).Value)
For w = LBound(vVALs, 1) To UBound(vVALs, 1) - 1
sTMP = ChrW(8203)
sPAR = vVALs(w, LBound(vVALs, 2))
For v = LBound(vVALs, 2) To UBound(vVALs, 2)
If Not CBool(InStr(1, sTMP, ChrW(8203) & vVALs(w + 1, v) & ChrW(8203), vbTextCompare)) Then
sTMP = sTMP & vVALs(w + 1, v) & ChrW(8203)
End If
If sPAR <> vVALs(w, Application.Min(v + 1, UBound(vVALs, 2))) Or v = UBound(vVALs, 2) Then
.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Resize(1, 2) = _
Array(sPAR, Replace(Mid(sTMP, 2, Len(sTMP) - 2), ChrW(8203), ", "))
sTMP = ChrW(8203)
If v < UBound(vVALs, 2) Then sPAR = vVALs(w, v + 1)
End If
Next v
Next w
End With
End Sub
I moved the 'Output Dat' results to the right of the 'Raw Data' due to an unknown number of rows to adjust for.
I have an excel with two columns (B & C) - Business case and solution, there will be multiple business cases which might have same solution, i want to merge it based on solution. Something like below -
BC1 Sol1
BC2 Sol2
BC3 Sol2
BC4 Sol3
BC5 Sol4
BC6 Sol4
BC7 Sol4
output should be -
BC1 Sol1
BC2, BC3 Sol2
BC4 Sol3
BC5, BC6, BC7 Sol4
i would like to do this in VBA and tried something like below -
LASTROW = Range("C" & Rows.Count).End(xlUp).Row 'get last row
For I = 0 To LASTROW Step 1
For J = I + 1 To LASTROW Step 1
If Cells(I, "C") = Cells(J, "C") Then
Cells(I, "B") = Cells(I, "B") & "," & Cells(J, "B")
Rows(J).Delete
End If
Next
Next
the above works, but is very slow when running on 1000 rows, i went through other questions similar to this but not good in VBA to mod that for above one. Can someone please help ?
As you have commented, using a variant array rather than looping the cells directly will speed this up enormously
To apply that here you could:
Determine the source data range, and copy that into an array
Create another array to contain the new data
Loop the source array, testing for the required patterns, and populate the destination array
Copy the new data back to the sheet, overwriting the old data
Sub Demo()
Dim ws As Worksheet
Dim rng As Range
Dim datSrc As Variant
Dim datDst As Variant
Dim i As Long
Dim j As Long
Dim rwOut As Long
Dim str As String
Set ws = ActiveSheet
With ws
Set rng = Range(.Cells(1, 2), .Cells(.Rows.Count, 3).End(xlUp))
datSrc = rng.Value
ReDim datDst(1 To UBound(datSrc, 1), 1 To UBound(datSrc, 2))
rwOut = 1
For i = 1 To UBound(datSrc, 1)
str = datSrc(i, 1)
If datSrc(i, 2) <> vbNullString Then
For j = i + 1 To UBound(datSrc, 1)
If datSrc(i, 2) = datSrc(j, 2) Then
str = str & "," & datSrc(j, 1)
datSrc(j, 2) = vbNullString
End If
Next
datDst(rwOut, 1) = str
datDst(rwOut, 2) = datSrc(i, 2)
rwOut = rwOut + 1
End If
Next
rng = datDst
End With
End Sub
I created a macro in Excel to mergue duplicated rows:
The idea is that if 2 rows or more have the same A B C columns, I mergue their D columns removing ABC duplicates.
I need to do this, but checking more colums.
My macro looks like this:
processingRow = 2
Do Until Cells(processingRow, 1).Value = ""
i = processingRow + 1
Do Until Cells(i, 1).Value = ""
If Cells(processingRow, 8) = Cells(i, 8) And _
Cells(processingRow, 12) = Cells(i, 12) And _
Cells(processingRow, 7) = Cells(i, 7) And _
Cells(processingRow, 6) = Cells(i, 6) And _
Cells(processingRow, 5) = Cells(i, 5) And _
Cells(processingRow, 4) = Cells(i, 4) And _
Cells(processingRow, 3) = Cells(i, 3) And _
Cells(processingRow, 2) = Cells(i, 2) And _
Cells(processingRow, 1) = Cells(i, 1) Then
If Cells(i, 14) <> "" Then
Cells(processingRow, 14) = Cells(processingRow, 14) & "," & Cells(i, 14)
End If
Rows(i).Delete
End If
i = i + 1
Loop
processingRow = processingRow + 1
Loop
When running the macro with 500 rows, it takes a while, but its still reasonable. But I need to run this macro in a excel with more than 2500 rows, and it takes so much time that its not practical anymore.
This is my first macro in excel using VBA, so I was wondering if there is a faster way to process rows/cells, since accessing them individually seems extremelly slow.
Any ideas?
EDITED: I missed that you weren't checking every column to determine what was a duplicate. This should be closer now:
Sub Tester()
Dim rngCheck As Range, rw As Range
Dim dict As Object, k As String, rwDup As Range
Dim rngDel As Range, tmp
Set dict = CreateObject("scripting.dictionary")
With ActiveSheet
Set rngCheck = .Range(.Cells(2, 1), _
.Cells(Rows.Count, 1).End(xlUp)).Resize(, 14)
End With
For Each rw In rngCheck.Rows
k = RowKey(rw)
If dict.exists(k) Then
Set rwDup = dict(k)
tmp = rw.Cells(14).Value
If Len(tmp) > 0 Then
rwDup.Cells(14).Value = rwDup.Cells(14).Value & "," & tmp
End If
If rngDel Is Nothing Then
Set rngDel = rw
Else
Set rngDel = Application.Union(rngDel, rw)
End If
Else
dict.Add k, rw
End If
Next rw
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub
'create a "key" for the row by joining all columns to be checked
Function RowKey(rw As Range) As String
Dim arr, x As Long, sep As String, rv As String
arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 12)
For x = LBound(arr) To UBound(arr)
rv = rv & sep & rw.Cells(arr(x)).Value
sep = Chr(0)
Next x
RowKey = rv
End Function
I have a code, written for me by #Jon49 that i adapted to suit my purposes :
The problem i have with this code is that it works for some of my files but produce an error 9 subscript out of range on others. essentially i have a loop that opens every file in a folder in turn performs the foloowing code. saves it then closes it before opening another one. The format of all the files is the same. so what is producing the error??
When the error happens and i debug it it tends to show the cause some where here :
sData(j, 7) = vData(1, j + 10)
sData(j, 8) = vData(i, j + 10)
sData(j, 9) = vData(3, j + 10)
sData(j, 10) = vData(2, j + 10)
SCROLL to BOTTOM for what i think is causing the error
Here is the code:
Range("k1").Select
Dim Parameters As String
Parameters = Range(ActiveCell.End(xlToRight).Offset(0, 0), ActiveCell).Count
Dim i As Long, j As Long, k As Long
Dim rData As Range
Dim sData() As String, sName As String
Dim wks As Worksheet
Dim vData As Variant
Application.EnableEvents = False 'Initialize worksheets
Set wks = ActiveSheet 'Get data
Set rData = wks.UsedRange
vData = rData
ReDim sData(1 To Parameters, 1 To rData.Columns.Count - 10)
rData.Offset(1).Clear
rData.Offset(11).Resize(1).Clear
<---- ??? not sure about importance of the line above because i commented out and the code will still work
For i = 1 To UBound(vData)
For j = 1 To UBound(sData)
For k = 1 To 6
sData(j, k) = vData(i, k)
Next k
sData(j, 7) = vData(1, j + 10)
sData(j, 8) = vData(i, j + 10)
sData(j, 9) = vData(3, j + 10)
sData(j, 10) = vData(2, j + 10)
Next j 'Print transposed data
wks.Range("A" & Application.Rows.Count).End(xlUp) _
.Offset(1).Resize(UBound(sData), UBound(sData, 2)) = sData
Next i
Application.EnableEvents = True
Range("K1").Select
Range(ActiveCell.End(xlToRight).Offset(0, 0), ActiveCell).Delete
Rows("2:" & Parameters + 1).Delete
One thing that i noticed is the files that the error seems to be produced on
has few parameters ( the two files ive noticed it erroring so far have 9 [will debug to sData(j, 10) = vData(2, j + 10)] and 7 [sData(j, 8) = vData(i, j + 10)]parameters each ) the others it is okay with so far each have more than 10 parameters . parameters being CH4, NO, NO2 etc
You're trying to access a value which doesn't exist in your sData or vData array. One or both of them have fewer "rows" or "columns" than you think. Try adding:
Msgbox "sData: #rows=" & ubound(sData,1) & " #cols=" & _
ubound(sData,2) & vbcrlf &
"vData #rows=" & ubound(vData,1) & " #cols=" & ubound(vData,2)
Immediately after
ReDim sData(1 To Parameters, 1 To rData.Columns.Count - 10)
See what values you get.