I have been able to find the column number and convert it to the letter, but I cannot figure out how to use the converted letter in defining a range. I keep getting a run time 1004 error.
I am trying to identify a column which contains the largest value in a specific row. Then use that column to find the first non zero cell and insert a row. Below is my code:
Sub ColNBR_Insert()
Dim maxCol As Long
Dim rngMaxCell As Range, rngVals As Range, C As Range, Where As Range
Dim lastNum0 As String
Dim ColLtr As String
Set rngVals = Worksheets("Charts").Range("F3:M3")
With Application.WorksheetFunction
Set rngMaxCell = rngVals.Find(.max(rngVals), LookIn:=xlValues)
If Not rngMaxCell Is Nothing Then
maxCol = rngMaxCell.Column
' MsgBox "The max value is in column " & maxCol
End If
End With
Set rngVals = Nothing
Set rngMaxCell = Nothing
'Convert To Column Letter
ColLtr = Split(Cells(1, maxCol).Address, "$")(1)
'Display Result
'MsgBox "Column " & maxCol & " = Column " & ColLtr
lastNum0 = "<>0"
Set C = Range(Range(ColLtr), Range(ColLtr))
C.Find(What:=lastNum0, After:=C(1), SearchDirection:=xlPrevious).Select
Selection.Offset(1).EntireRow.Insert Shift:=xlDown
End Sub
No need to do all this conversion... just use Columns.
Set C = Range(Range(ColLtr), Range(ColLtr))
although problematic, is probably easier done with
Set C = Columns(maxCol)
Related
How do I get the position of the last non-empty cell in a filtered column without dropping the applied Autofilter? I understand it's easy to get the number of the last visible row with
Dim ws as Worksheet, rng As Range
Set rng = Range(Letter & 1 & ":" & Letter & 1) ' where Letter is the letter code of the column
GetLastVisibleRow = ws.Range(Split(ws.Cells(, rng.Column).Address, "$")(1) & ws.Rows.count).End(xlUp).row
but I need the number of the last filled row instead. At the same time, I'd like to avoid setting
ws.AutoFilterMode = False
if it's possible.
Thanks in advance.
Probably not the most efficient or fastest method, but this appears to work:
Function GetLastCellOfColumn(ColLetter As String) As Range
Dim Col As Range
Dim Rw As Long
Set Col = Range(ColLetter & ":" & ColLetter)
Set GetLastCellOfColumn = Intersect(ActiveSheet.UsedRange, Col)
For Rw = GetLastCellOfColumn.Cells.Count To 1 Step -1
If Len(GetLastCellOfColumn.Cells(Rw).Value) > 0 Then
Set GetLastCellOfColumn = GetLastCellOfColumn.Cells(Rw)
Exit Function
End If
Next
End Function
A charming solution by #jkpieterse plus a useful comment by #BigBen is exactly what I was looking for. Just to finalize the thread, the function returning the row number is
Function GetLastFilledCellOfColumn(ws As Worksheet, ColLetter As String) As Long
Dim Col As Range, Urng As Range, Rw As Long
Set Col = ws.Range(ColLetter & ":" & ColLetter)
Set Urng = Intersect(ws.UsedRange, Col)
For Rw = Urng.Cells.count To 1 Step -1
If Not IsEmpty(Urng.Cells(Rw)) Then
GetLastFilledCellOfColumn = Rw
Exit Function
End If
Next
End Function
Problem solved.
So maybe this is an alternative way to look into:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .Range("_FilterDatabase").Columns(col)
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
I'm afraid I rushed this a little and might have made a mistake but will have to get going. Hopefully you understand whats going on =)
Edit:
The above would definately work, but as figured out through the chat, there is actually a ListObject involved, called Table1, which throws of the AutoFilter range. So here are two alternative ways of doing the same thing:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .Range("Table1")
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
Or, when you don't know the name of the table:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .ListObjects(1).Range
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
I have a worksheet with some 100k rows by perhaps 2 dozen columns. Presently I am coloring a specific column, say "ABC", that when the value is > x set the interior.colorindex to y. At the moment I have to sort this column descending, then using a FOR EACH statement, cycle through each of the row cells until the value < x, coloring the cell as each NEXT is reached.
What I am trying to be is make this far more efficient by using the Excel MATCH function, find the last row number, then color the cells in one block rather than individual cells but cannot get my clumsy coding to work correctly. Everything I have read appears to indicate that the MATCH function is supported in vbscript, but I need some assistance from some kind soul figure this out. I have trimed my code down to the relevant section and would appreciate and assistance provided. Please forgive my ignorance, I am very new to this coding thing, and this is my first post requesting help.
Dim objXLApp, objXLWb, objXLWs, objWorksheet, WorksheetFunction
Dim InFile, OutFile
Dim ObjRange, ObjRange2, ObjRange3, rng, rng1, rng2, trng
Dim iRows, iCols, iR, iC, lRow, fRow, col, rw, tRow
Dim ColSearch, StartTime, EndTime, TotalTime
Dim cTeal, cPurple, cCyan, cVal, opVal
Dim Counttcolor, Countpcolor, Countccolor, clr
Dim vMsg
' input parameters
InFile = Wscript.Arguments.Item(0)
OutFile = Wscript.Arguments.Item(1) 'this output file CAN be the same as the input thereby overwriting if required.
Set objXLApp = CreateObject("Excel.Application")
'application function SWITCHES - set to TRUE to enable
objXLApp.Visible = True
objXLApp.EnableEvents = True
objXLApp.DisplayAlerts = True
objXLApp.ScreenUpdating = True
objXLApp.DisplayStatusBar = False
vMsg = 1 ' set to 1 to turn on timer prompts for each processing section
Set objXLWb = objXLApp.Workbooks.Open(InFile)
'Select the appropriate Sheet in the Workbook
Set objXLWs = objXLWb.Sheets(1)
objXLWb.Sheets(1).Activate
objXLWs.DisplayPageBreaks = False
'decleration must be AFTER opening the input file
objXLApp.Calculation = xlCalculationManual
objXLApp.CalculateBeforeSave = True
' Set range and count Row & Columns
Set objRange = objXLWs.UsedRange
iRows = objRange.Rows.Count
iCols = objRange.Columns.Count
'MsgBox iRows
'MsgBox iCols
StartTime = Timer()
ColSearch = "ABC" 'COLUMN AS
For iC = 1 To iCols
If InStr(objRange.Item(1, iC).Value2,ColSearch) Then
'sort the column descending to bring highest records to the top
Set objRange = objXLWs.UsedRange
Set objRange2 = objXLApp.Range(objRange.Item(2, iC).Address) 'ABC
objRange.Sort objRange2, xlDescending, , , , , , xlYes
cTeal = 15 'set the teal minimum value
'set the range for the match function to search for the min cTeal value
rng = objRange.Item(2, iC).Address &":"& objRange.Item(iRows, iC).Address
'search for the first row number containing the first value less than cTeal
tRow = objXLApp.match(cTeal, rng, -1)
MsgBox tRow 'this presently fails here with object required if commented fails at set trng with reference to tRow variable
'set the range for coloring the entire block of cells
Set trng = objRange.Item(2, iC).Address &":"& objRange.Item(tRow, iC).Address
objXLApp.Range(trng).Interior.ColorIndex = 42 'Teal
End If
Next
EndTime = Timer()
If vMsg = 1 Then MsgBox "ABC: " & FormatNumber(EndTime - StartTime, 2)
Problem solved, it was a range issue. Needed to set the range to a single column (ie: A:A and not the cell references as existed) but I had something wrong in my existing code. Thanks anyway.
For reference sake, here is the working code:
ColSearch = "ABC"
For iC = 1 To iCols
If InStr(objRange.Item(1, iC).Value2,ColSearch) then
'to get the column letter for setting the rng param for match function
col_letter = Split(objRange.Item(1, iC).Address, "$")(1)
cTeal = 14
cPurple = 5
'set the range address string
col_letter = col_letter & ":" & col_letter
'set the range to a single column letter/name for the match function
set rng = objXLApp.Range(col_letter)
tRow = objXLApp.Match(cTeal,rng,-1) 'find the last row for Teal value
pRow = objXLApp.Match(cPurple,rng,-1) 'find the row for Purple value
'Msgbox tRow
'Msgbox pRow
objXLApp.Range(objRange.Item(2, iC).Address & ":" & objRange.Item(tRow, iC).Address).Interior.ColorIndex = 42 'Teal
objXLApp.Range(objRange.Item(tRow+1, iC).Address & ":" & objRange.Item(pRow, iC).Address).Interior.ColorIndex = 34 'Cyan
objXLApp.Range(objRange.Item(pRow+1, iC).Address & ":" & objRange.Item(objRange.Item(2, iC).End(xlDown).Row, iC).Address).Interior.ColorIndex = 39 'Purple
End If
Next
I am trying to convert a text file to Excel sheet. I have to remove some data elements and copy some data elements to several columns. To remove some data, I have to look for a certain String (RUN). After I have that address, I have to search for the next RUN. Inside those two String range, I have to search for another String (NET) and remove it. I have to do it throughout the datasheet since this is frequent.
Here is the code I am trying to use.
Dim name As String: name = "RUN"
Dim secondName As String: secondName = "NET"
Dim rgSearch As Range
' set the range to entire sheet
Set rgSearch = Range(Cells.Address)
Dim rgSearch1 As Range
Dim cell As Range
'search for first occurrence of RUN
Set cell = rgSearch.Find(name)
Dim tempCell As Range
' If not found then exit
If cell Is Nothing Then
Debug.Print "Not found"
Exit Sub
End If
' Store first cell address
Dim firstCellAddress As String, firstRow As Integer, secondRow As Integer
'store address of first result
firstCellAddress = cell.Address
secondRow = cell.Row
Do
'save range to another range for next iteration
Set tempCell = cell.Select
'row variables are for alternate solution I tried
firstRow = secondRow
Debug.Print "Found: " & cell.Address
' search for next instance
Set cell = rgSearch.FindNext(cell)
,set next instance
secondRow = cell.Row
Set rgSearch1 = Range(tempCell, cell).Select
Loop While firstCellAddress <> cell.Address
I have also tried using
Set rgSearch1 = Range("B" & firstRow + 1 & ":B" & secondRow - 1).Select
instead of putting cells inside the range but I get the same result. That is why those firstRow, secondRow variables are there.
With both ideas, I am getting Object Required error. Could someone please show me what I am doing wrong?
I currently have a macro that copies the value from a specific cell from one sheet(BACKEND), and pastes in specific column in another sheet (EXPORT_DATA), in the next blank row.
Sub copy_values(Optional Source As String = "A1", Optional Source2 As String = "A1")
Dim R As Range
Dim col As Long
col = Range(Source).Column
Set R = Worksheets("EXPORT_DATA").Cells(Rows.Count, col).End(xlUp)
If Len(R.Value) > 0 Then Set R = R.Offset(1)
R.Value = Worksheets("BACKEND").Range(Source2).Value
End Sub
It works well, but I want to replace the the function in where it pastes the data in the next blank cell in a column, to a function in where it pastes the data in a row in where a cell holds a specified value.
For example, the older function would do the following
step 1:
c1 c2 c3
a b 4
c d 6
step 2 (after macro executed):
c1 c2 c3
a b 4
c d 6
c d 5
But I need a new function that does this:
step 2 (C1 value of "c" specified, macro executed):
c1 c2 c3
a b 4
c d 5
See how this goes for you. Not sure how you are calling etc but it should be a reasonable starting point. I only gave it a really quick test
Sub copy_values_SINGLE(cValue As Variant, Optional Source As String = "A1", Optional Source2 As String = "A1")
' Not sure of what value type c in your question would be but expects a single value to test against the column provided as Source
' Requires cValue to be provided
Dim R As Range
Dim col As Long
Dim destRow As Integer
col = Range(Source).Column
On Error Resume Next
destRow = 0
destRow = Worksheets("EXPORT_DATA").Columns(col).Find(cValue, SearchDirection:=xlPrevious).Row
If destRow = 0 Then destRow = Worksheets("EXPORT_DATA").Cells(Rows.Count, col).End(xlUp).Row + 1 ' if cValue isnt found reverts to the last row as per previous code
On Error GoTo 0
Set R = Worksheets("EXPORT_DATA").Cells(destRow, col)
R.Value = Worksheets("BACKEND").Range(Source2).Value
End Sub
This may work
Sub copy_values(Optional Source As String = "A1", Optional Source2 As String = "A1")
Dim R As Variant
Dim col As Long
col = Range(Source).Column
Dim mrn As String
Dim FoundCell As Excel.Range
Dim myVal As String
R = Worksheets("BACKEND").Range(Source2).Text
myVal = Worksheets("BACKEND").Range(Source2).Text
mrn = Worksheets("BACKEND").Range("A5").Value
Set FoundCell = Worksheets("EXPORT_DATA").Range("A:A").Find(what:=mrn, lookat:=xlWhole, searchdirection:=xlPrevious)
If Not FoundCell Is Nothing Then
' MsgBox (R & " " & col & " " & FoundCell.Row)
Worksheets("EXPORT_DATA").Range("Q" & FoundCell.Row).Value = R
Else
MsgBox "error"
End If
End Sub
Still not 100% certain, but I think this is what you are after. The file loop all values in column A of the EXPORT_DATA file and compared them to the value in cell A1 of the BACKEND worksheet. If it finds the value it replaces the value in column B, if it cannot find the value, it adds it at the end:
Sub copy_values_SINGLE()
Dim R As Range
Dim rowCount As Long
Dim varValue As Variant
rowCount = Application.WorksheetFunction.CountA(Worksheets("EXPORT_DATA").Range("A:A"))
For s = 1 To rowCount
If Worksheets("EXPORT_DATA").Range("A" & s).Value = Worksheets("BACKEND").Range("A1").Value Then
Worksheets("EXPORT_DATA").Range("A" & s & ":B" & s).Value = Worksheets("BACKEND").Range("A1:B1").Value
Exit For
Else
If s = rowCount Then
Set R = Worksheets("EXPORT_DATA").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
R.Value = Worksheets("BACKEND").Range("A1:B1").Value
End If
End If
Next s
End Sub
Let me know if this works for you.
I am working through my first VBA book and would appreciate if someone would point me in the right direction. How would I transfer a range of rows into a single cell with carriage returns? I would then like to repeat this action for all ranges in the column.
I think I need to:
find the first cell with a value in the column
verify that the next row is not empty
find the last cell in the range
perform "the operation" on the range
Following up on my comments. here is a very simple way to achieve what you want.
Option Explicit
'~~> You can use any delimiter that you want
Const Delim = vbNewLine
Sub Sample()
Dim rngInput As Range, rngOutput As Range
Application.ScreenUpdating = False
Set rngInput = Range("A1:A5") '<~~ Input Range
Set rngOutput = Range("B1") '<~~ Output Range
Concatenate rngInput, rngOutput
Application.ScreenUpdating = True
End Sub
Sub Concatenate(rng1 As Range, rng2 As Range)
Dim cl As Range
Dim strOutPut As String
For Each cl In rng1
If strOutPut = "" Then
strOutPut = cl.Value
Else
strOutPut = strOutPut & Delim & cl.Value
End If
Next
rng2.Value = strOutPut
End Sub
Within the context of a worksheet-level code, the following will work. Column 2 is hard-coded, so you might want to pass in a value or otherwise modify it to fit your needs.
Dim rng As Range
Set rng = Me.Columns(2)
Dim row As Integer
row = 1
' Find first row with non-empty cell; bail out if first 100 rows empty
If IsEmpty(Me.Cells(1, 2)) Then
Do
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2)) = False Or row = 101
End If
If row = 101 Then Exit Sub
' We'll need to know the top row of the range later, so hold the value
Dim firstRow As Integer
firstRow = row
' Combine the text from each subsequent row until an empty cell is encountered
Dim result As String
Do
If result <> "" Then result = result & vbNewLine
result = result & Me.Cells(row, 2).Text
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2))
' Clear the content of the range
Set rng = Me.Range(Me.Cells(firstRow, 2), Me.Cells(row, 2))
rng.Clear
' Set the text in the first cell
Me.Cells(firstRow, 2).Value2 = result