What is wrong with this code? It is supposed to return header (1st row) of a column in which it finds "1". I pass the row number (nr) and it is supposed to look between columns M and T (inclusive)
Function who(ByVal rowNr As Integer) As String
Dim temp As String
Dim ws As Worksheet
With ActiveSheet
Set ws = ActiveWorkbook.Sheets(.Name)
End With
For i = 13 To 20 Step 1
If ws.Cells(i, rowNr).Value = 1 Then
temp = temp & " " & ws.Cells(i,1).Value
End If
Next i
who = temp
End Function
The error I get is
Application-Defined or Object-Defined
error
And marks line
If ws.Cells(i, nr).Value = 1 Then
I truly dislike VB.
If nr is used as a numerical value, why are you sending it in as a String. Try changing that to an Integer and you should be a bit further along at least.
Edit: I forgot that I think you might have mixed up rows/columns as well. I think maybe you want it to be:
If ws.Cells(nr, i).Value = 1 Then
This worked for me
Function who(ByVal rowNr As Long) As String
Dim temp As String
Dim ws As Worksheet
Dim i As Long
Set ws = ActiveSheet
For i = 13 To 20 Step 1
If ws.Cells(rowNr, i).Value = 1 Then
temp = temp & " " & ws.Cells(1, i).Value
End If
Next i
who = Trim(temp)
End Function
Related
I've got an excel spreadsheet with several columns, two of them have an ID (that repeats itself) and a date.
What I'm trying to accomplish is to delete all rows by ID leaving only the row with the max date.
I have a second sheet with all the unique IM's.
This is what I have at the moment:
Public Sub sbMaxDateByIM()
Dim max As Date
Dim currentIM As String
Dim MaxDateCurrentIM As Date
Dim dateRange As Range
Dim imrange As Range
Application.Sheets("sheet1").Activate
Set dateRange = ActiveSheet.Range(ActiveSheet.Range("E2"), ActiveSheet.Range("E2").End(xlDown))
Set imrange = ActiveSheet.Range(ActiveSheet.Range("A2"), ActiveSheet.Range("A2").End(xlDown))
Application.ScreenUpdating = False
Application.Sheets("UniqueIMS").Activate
For IM = 1 To ActiveSheet.Range(ActiveSheet.Range("A1"), ActiveSheet.Range("A1").End(xlDown)).Rows.Count
currentIM = Sheets("UniqueIMS").Cells(IM, 1).Value
MaxDateCurrentIM = Evaluate("=MAX(IF(""imrange""=""currentIM"",))""dateRange""")
For J = 2 To Range(Range("E2"), Range("E2").End(xlDown)).Rows.Count + 1
If currentIM = Sheets("Sheet1").Cells(IM, 1).Value And CDate(Sheets("Sheet1").Cells(J, 5).Value) < MaxDateCurrentIM Then
Rows(J).EntireRow.Delete
End If
Next J
Next IM
Application.ScreenUpdating = True
End Sub
Any ideias would be very much appreciated, the line of code not working is:
MaxDateCurrentIM = Evaluate("=MAX(IF(""imrange""=""currentIM"",))""dateRange""")
Can you try this? Your formula syntax was off I think. (Also why set currentIM twice?) Plus, when deleting rows you need to go backwards.
Public Sub sbMaxDateByIM()
Dim max As Date
Dim currentIM As String
Dim MaxDateCurrentIM As Date
Dim dateRange As Range
Dim imrange As Range
With Sheets("sheet1")
Set dateRange = .Range(.Range("E2"), .Range("E2").End(xlDown))
Set imrange = .Range(.Range("A2"), .Range("A2").End(xlDown))
End With
Application.ScreenUpdating = False
Application.Sheets("UniqueIMS").Activate
For IM = 1 To Range(Range("A1"), Range("A1").End(xlDown)).Rows.Count
currentIM = Sheets("sheet1").Cells(IM, 1).Value
MaxDateCurrentIM = Evaluate("=MAX(IF(" & imrange.Address & "=""" & currentIM & """," & dateRange.Address & "))")
For J = Range(Range("E2"), Range("E2").End(xlDown)).Rows.Count + 1 To 2 Step -1
If currentIM = Sheets("Sheet1").Cells(IM, 1).Value And CDate(Sheets("Sheet1").Cells(J, 5).Value) < MaxDateCurrentIM Then
Rows(J).EntireRow.Delete
End If
Next J
Next IM
Application.ScreenUpdating = True
End Sub
Evaluate is used to run Excel functions - but Excel has no idea what imrange and currentim are, they only exist inside the vba routine. You either need to rewrite your maxif in terms excel understands, or use vba code to do the same job as maxif
I have been trying to write a program that will loop through all the cells in an excel sheet and if one starts with a '#' it should display a message. here's the code:
(template is a worksheet variable)
Private Function processTemplate()
Dim total As Long
total = template.UsedRange.count
Dim count As Integer
count = 0
While count <= total
If template.Cells(count).Value Like "[#]*" Then 'Here I get a error
MsgBox "Found #"
End If
count = count + 1
Wend
End Function
I have isolated the error to using a variable inside of cells(). If I replace count with some number (like 8) it works fine. I am getting error 1004 on the line If template.Cells(count).Value Like "[#]*" Then
If I make total an Integer it has the same error at the same place. After about 2-3 hrs of research/banging my head on the wall I have no idea. I initially got the error when assigning template.cells(row, col).Value to a string variable.
Here's my code now:
Private Sub processTemplate()
MsgBox Len("")
Dim str As String
Dim rows As Long
Dim cols As Long
rows = template.UsedRange.Height
cols = template.UsedRange.Width
Dim row As Integer
row = 1
While row < rows
Dim col As Integer
col = 1
While col < cols
str = template.Cells(row, col).Text
If Len(str) > 0 Then
If Left(template.Cells(row, col).Text, 1) = "#" Then
MsgBox "Found IT"
End If
End If
Rem MsgBox template.Parent.Name & ": " & template.Name & ", Cell(" & row & ", " & col & "): " & template.Cells(row, col).Value
col = col + 1
Wend
row = row + 1
Wend
End Sub
Now I get the error on str = template.Cells(row, col).Text
We can use a sub rather than a function
We loop over all the cells in UsedRange looking for a # as the first character in the cell.
Sub FindThePound()
Dim r As Range, pound As String, template As Worksheet
pound = "#"
Set template = ActiveSheet
For Each r In template.UsedRange
If Left(r.Value, 1) = pound Then
MsgBox "Found # in " & r.Address(0, 0)
End If
Next r
End Sub
EDIT#1
This version loops over all the cells, but does not test cells containing formulas
Sub FindThePound()
Dim r As Range, pound As String, template As Worksheet
pound = "#"
Set template = ActiveSheet
For Each r In template.UsedRange
If r.HasFormula = False Then
If Left(r.Value, 1) = pound Then
MsgBox "Found # in " & r.Address(0, 0)
End If
End If
Next r
End Sub
You could use find/ find next function which i guess bit faster than looping through each cell and do string comparison.
With Worksheets(1).Range("a1:a500") 'Provide the search range
Set c = .Find(2, lookin:=xlValues) ' searching for 2 in cell value
If Not c Is Nothing Then
firstAddress = c.Address 'first occurance
Do
'do whatever you want to do with the matches even replace them
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Reference:
http://msdn.microsoft.com/en-us/library/office/ff196143(v=office.15).aspx
I have a string compressed into one cell. I need to separate each part of the string into their own cell, while copying the data from the same row.
Here is my example data:
A | B
Row1 ABC ABD ABE ABF | CODE1
Row2 BCA DBA EBA FBA | CODE2
Row3 TEA BEF | CODE3
The result would be:
A B
ABC CODE1
ABD CODE1
ABE CODE1
ABF CODE1
BCA CODE2
DBA CODE2
EBA CODE2
FBA CODE2
TEA CODE3
BEF CODE3
I have about 2000 rows and would literally take 30 years to use the text to column function for this. So I am trying to write a vba macro. I think I am making this harder than it needs to be. Any thoughts or pushes in the right direction would be appreciated. Thanks in advance for any help.
This will work, (but it's mighty inefficient unless you do it in an array... nevertheless for only 2000 rows, you won't even notice the lag)
Function SplitThis(Str as String, Delimiter as String, SerialNumber as Long) As String
SplitThis = Split(Str, Delimiter)(SerialNumber - 1)
End Function
Use it as
= SPLITTHIS("ABC EFG HIJ", " ", 2)
' The result will be ...
"EFG"
You will still need to put in a whole lot of extra error checking, etc. if you need to use it for a distributed application, as the users might put in values greater than the number of 'split elements' or get delimiters wrong, etc.
I like iterating over cells for problems like this post.
' code resides on input sheet
Sub ParseData()
Dim wksOut As Worksheet
Dim iRowOut As Integer
Dim iRow As Integer
Dim asData() As String
Dim i As Integer
Dim s As String
Set wksOut = Worksheets("Sheet2")
iRowOut = 1
For iRow = 1 To UsedRange.Rows.Count
asData = Split(Trim(Cells(iRow, 1)), " ")
For i = 0 To UBound(asData)
s = Trim(asData(i))
If Len(s) > 0 Then
wksOut.Cells(iRowOut, 1) = Cells(iRow, 2)
wksOut.Cells(iRowOut, 2) = s
iRowOut = iRowOut + 1
End If
Next i
Next iRow
MsgBox "done"
End Sub
Assuming your data is on the first sheet, this populates the second sheet with the formatted data. I also assume that the data is uniform, meaning there is the same type of data on every row until the data ends. I did not attempt the header line.
Public Sub FixIt()
Dim fromSheet, toSheet As Excel.Worksheet
Dim fromRow, toRow, k As Integer
Dim code As String
Set fromSheet = Me.Worksheets(1)
Set toSheet = Me.Worksheets(2)
' Ignore first row
fromRow = 2
toRow = 1
Dim outsideArr() As String
Dim insideArr() As String
Do While Trim(fromSheet.Cells(fromRow, 1)) <> ""
' Split on the pipe
outsideArr = Split(fromSheet.Cells(fromRow, 1), "|")
' Split left of pipe, trimmed, on space
insideArr = Split(Trim(outsideArr(0)), " ")
' Save the code
code = Trim(outsideArr(UBound(outsideArr)))
' Skip first element of inside array
For k = 1 To UBound(insideArr)
toSheet.Cells(toRow, 1).Value = insideArr(k)
toSheet.Cells(toRow, 2).Value = code
toRow = toRow + 1
Next k
fromRow = fromRow + 1
Loop
End Sub
Let me try as well using Dictionary :)
Sub Test()
Dim r As Range, c As Range
Dim ws As Worksheet
Dim k, lrow As Long, i As Long
Set ws = Sheet1 '~~> change to suit, everything else as is
Set r = ws.Range("B1", ws.Range("B" & ws.Rows.Count).End(xlUp))
With CreateObject("Scripting.Dictionary")
For Each c In r
If Not .Exists(c.Value) Then
.Add c.Value, Split(Trim(c.Offset(0, -1).Value))
End If
Next
ws.Range("A:B").ClearContents
For Each k In .Keys
lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
If lrow = 1 Then i = 0 Else i = 1
ws.Range("A" & lrow).Offset(i, 0) _
.Resize(UBound(.Item(k)) + 1).Value = Application.Transpose(.Item(k))
ws.Range("A" & lrow).Offset(i, 1).Resize(UBound(.Item(k)) + 1).Value = k
Next
End With
End Sub
Above code loads all items in Dictionary and then return it in the same Range. HTH.
Here is an approach using a User Defined Type, Collection and arrays. I've been using this lately and thought it might apply. It does make writing the code easier, once you get used to it.
The user defined type is set in a class module. I called the type "CodeData" and gave it two properties -- Code and Data
I assumed your data was in columns A & B starting with row 1; and I put the results on the same worksheet but in columns D & E. This can be easily changed, and put on a different worksheet if that's preferable.
First, enter the following code into a Class Module which you have renamed "CodeData"
Option Explicit
Private pData As String
Private pCode As String
Property Get Data() As String
Data = pData
End Property
Property Let Data(Value As String)
pData = Value
End Property
Property Get Code() As String
Code = pCode
End Property
Property Let Code(Value As String)
pCode = Value
End Property
Then put the following code into a Regular module:
Option Explicit
Sub ParseCodesAndData()
Dim cCodeData As CodeData
Dim colCodeData As Collection
Dim vSrc As Variant, vRes() As Variant
Dim V As Variant
Dim rRes As Range
Dim I As Long, J As Long
'Results start here. But could be on another sheet
Set rRes = Range("D1:E1")
'Get Source Data
vSrc = Range("A1", Cells(Rows.Count, "B").End(xlUp))
'Collect the data
Set colCodeData = New Collection
For I = 1 To UBound(vSrc, 1)
V = Split(vSrc(I, 1), " ")
For J = 0 To UBound(V)
Set cCodeData = New CodeData
cCodeData.Code = Trim(vSrc(I, 2))
cCodeData.Data = Trim(V(J))
colCodeData.Add cCodeData
Next J
Next I
'Write results to array
ReDim vRes(1 To colCodeData.Count, 1 To 2)
For I = 1 To UBound(vRes)
Set cCodeData = colCodeData(I)
vRes(I, 1) = cCodeData.Data
vRes(I, 2) = cCodeData.Code
Next I
'Write array to worksheet
Application.ScreenUpdating = False
rRes.EntireColumn.Clear
rRes.Resize(rowsize:=UBound(vRes, 1)) = vRes
Application.ScreenUpdating = True
End Sub
Here is the solution I devised with help from above. Thanks for the responses!
Sub Splt()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
Columns("A").Insert
For i = LR To 1 Step -1
With Range("B" & i)
If InStr(.Value, " ") = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, " ")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("B").Delete
LR = Range("A" & Rows.Count).End(xlUp).Row
With Range("B1:C" & LR)
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub
I have a sheet that has a table on it, the following function will be used to search another sheet and return the number of times the agents name shows up;
The problem I'm having is that if I try to copy and paste the value it will change from a number to '#Value!'. Also, when switching worksheets and then switching back to the worksheet that has the UDF being called it changes all values to '#Value!'
Here is the function and how it is called. Any help would be greatly appreciated.
Public Function GetMatrixCount(AgentName As String) As Integer
Dim matrixSheet As Worksheet, mContainer() As String, c As Integer, m As Integer, y As Integer
Dim fullRange As Range, l As Range, lastRow As Integer
Dim firstThree As String, curAgent As String
'toDo
'return zero if the matrix updates worksheet doesn't exist or the input string is empty
On Error Resume Next
Set matrixSheet = Sheets("Matrix Updates")
On Error GoTo 0
If matrixSheet Is Nothing Or Not Trim(AgentName) <> "" Then
GetMatrixCount = 0
Exit Function
End If
'get month number user wants to input from the title at the top of the page - used to do value check on matrix updates data
mContainer() = Split(Range("B1").Value, " ")
m = month(DateValue(mContainer(UBound(mContainer) - 1) & " 1"))
y = mContainer(UBound(mContainer))
firstThree = Left(AgentName, 3)
lastRow = matrixSheet.Cells(Rows.Count, 1).End(xlUp).Row
c = 0
Set fullRange = matrixSheet.Range("B2:B" & lastRow)
For Each l In fullRange.Cells
curAgent = l.Offset(0, 1).Value
If month(l.Value) = m And year(l.Value) = y And Left(curAgent, 3) = firstThree And Mid(curAgent, InStrRev(curAgent, " ") + 1) = Mid(AgentName, InStrRev(AgentName, " ") + 1) Then
c = c + 1
End If
If l.Value = "" Then
Exit For
End If
Next
GetMatrixCount = c
End Function
Usage:
=GetMatrixCount(B4)
B4: John Doe
UPD:
Try to write following:
Set wb = ThisWorkbook
Set matrixSheet = wb.Sheets("Matrix Updates")
It should fix the problem when you switch workbooks.
I have 3 issues with the following piece of code:
Intention of code: I have a table of data, 4 columns (F,G, H and I) wide and X rows long (X is typically between 5 and 400). I have a list of dates in column M, typically no more than 8 dates. Column H of table, contains dates as well. I want to find the dates that are in both columns (H and M) and whenever they appear, go to the same row in column I and set its value to zero, and the one after it (so if a match was in H100, then I100 and I101 would be zeroed).
issues with code: edited 1) as per feedback.
1) I have, using an if formula (=if(H100=M12,1,0), verified that there is one match, as how the spreadsheet sees it. The macro does not find this match, despite confirmation from the if formula. Cells I100 and I101 have nonzero values, when they should be zeroed.
2) the code runs, but takes about 3 minutes to go through 3 sheets of 180 rows of data. What can be done to make it run faster and more efficiently? It could have up to 30 sheets of data, and 400 rows (extreme example but possible, in this instance im happy to let it run a bit).
3) Assuming my data table before the macro is run, is 100 rows long, starting in row 12, after the macro, column I has nonzero values for 111 rows, and zeroes for the next 389. Is there a way I can prevent it from filling down zeroes, and leaving it blank?
I am using a correlate function afterwards on column I and there huge agreement of 0's with 0's is distorting this significantly. Thanks in advance,
Sub DeleteCells()
Dim ws As Worksheet
Dim cell As Range, search_cell As Range
Dim i As Long
Dim h As Long
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then
For Each cell In ws.Range("H12:H500")
On Error Resume Next
h = ws.Range("G" & Rows.Count).End(xlUp).Row
i = ws.Range("L" & Rows.Count).End(xlUp).Row
Set search_cell = ws.Range("M12:M" & h).Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)
On Error GoTo 0
If Not search_cell Is Nothing Then
ws.Range("I" & cell.Row).Value = 0
ws.Range("I" & cell.Row + 1).Value = 0
Set search_cell = Nothing
End If
Next cell
End If
Next ws
Application.ScreenUpdating = True
Set ws = Nothing: Set cell = Nothing: Set search_cell = Nothing
End Sub
EDIT: TESTED CODE, will work for 0, 1 row of data in H/M column starting from row 12?
EDIT: Updated the cell to handle case with 1 line of data, untested :|
I will give my solution first, this one should be much faster because it read the cells into memory first
Please comment if it doesn't work or you have further question
Sub DeleteCells()
Dim ws As Worksheet
Dim i As Long
Dim h As Long
Dim MColumn As Variant ' for convinence
Dim HColumn As Variant
Dim IColumn As Variant
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then 'matching the target sheet
' matching the rows where column M's date matches column H's date
'starting row num is 12
With ws ' for simplifying the code
h = .Range("H" & .Rows.count).End(xlUp).Row
If h = 12 Then ' CASE for 1 row only
If Range("H12").Value = Range("M12").Value Then
Range("I12:I13").Value = ""
End If
ElseIf h < 12 Then
' do nothing
Else
ReDim HColumn(1 To h - 11, 1 To 1)
ReDim MColumn(1 To h - 11, 1 To 1)
ReDim IColumn(1 To h - 10, 1 To 1)
' copying the data from worksheet into 2D arrays
HColumn = .Range("H12:H" & h).Value
MColumn = .Range("M12:M" & h).Value
IColumn = .Range("I12:I" & h + 1).Value
For i = LBound(HColumn, 1) To UBound(HColumn, 1)
If Not IsEmpty(HColumn(i, 1)) And Not IsEmpty(MColumn(i, 1)) Then
If HColumn(i, 1) = MColumn(i, 1) Then
IColumn(i, 1) = ""
IColumn(i + 1, 1) = ""
End If
End If
Next i
'assigning back to worksheet cells
.Range("H12:H" & h).Value = HColumn
.Range("M12:M" & h).Value = MColumn
.Range("I12:I" & h + 1).Value = IColumn
End If
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub