Sub einfarben()
Worksheets("2_Basisdata").Activate
Dim Startvalue As Variant
Dim Endvalue As Variant
Application.InputBox("startvalue") = Startvalue
Application.InputBox("endvalue") = Endvalue
Dim C As Range
Dim rng As Range
rng = Range("B2;J13")
For Each C In rng
On Error Resume Next
If Startvalue < C And C < Endvalue Then
C.Font.ColorIndex = 4
End If
Next C
End Sub
My Problem: I got Several Runtime Errors.
The Holdingmarker Pops up at the First Application.Inputbox
My Goal is to achieve that the Cells where the Value is between Start and End Changing to green..
You need to switch the right hand side and the left hand sides of the two statements involving InputBox. The first one should read
Startvalue = Val(InputBox("start value"))
Similarly for the next line. There doesn't seem to be much point in using Application.InputBox here so I dropped the Application. I added Val to convert the input strings to numbers.
Also, you need to use Set when you assign a range to a range variable:
Set rng = Range("B2:J13")
Related
I am trying to debug the following function, when used as in the sub main listed right above it.
For clarification on the purpose of the arguments for the function it will use
15 is the Interval and
4 is where it will start the range row,
64 is where it will end the range row,
3 is the column the range starts in
3 is the column the range ends in.
The problem lies with the first argument xInterval, while it selects this interval I am getting a single extra selection right before the second. For example Running this code selects (C4, C18, C19, C34, C49, C64) I'm not sure where the C18 is coming from and do not want it. Any suggestions welcome. Thank you!
Sub Main()
Dim rng As Range
Set rng = Every_Fiffteen_min(15, 4, 64, 3, 3)
End Sub
Function Every_Fiffteen_min(xInterval As Integer, row_start As Long, row_end As Long, Colu_start As Integer, Colu_end As Integer) As Range
' Input an interval defined by xInterval that will set the interval of rows to select.
' Using an input for the range row start, row end, column start and column end in numeric values not alpha.
' I have additional functions that will be used to calculate the row start, end, column start and column end, which is why I need these.
Dim CustomRange As Range 'Inputrng
Dim SelectRow As Range ' OutRng
Dim rng As Range
Dim i As Integer
With Sheets("Data Import")
Set CustomRange = .Range(Cells(row_start, Colu_start), Cells(row_end, Colu_end))
Set SelectRow = CustomRange.Rows(xInterval)
For i = 1 To CustomRange.Rows.Count Step xInterval
Set rng = CustomRange.Cells(i, 1)
If SelectRow Is Nothing Then
Set SelectRow = rng
Else
Set SelectRow = Union(SelectRow, CustomRange.Rows(i))
End If
Next i
Application.Goto SelectRow
End With
End Function
The extra range is coming because of your line Set SelectRow = CustomRange.Rows(xInterval)
You already loop from the row_start to row_end. So all of the specified Ranges will be added to SelectRow. But then you also have that line on top of the loop which is adding the unwanted range into SelectRow.
If you remove this line, the issue will be fixed. But then during the first loop you will be doing Set SelectRow = rng instead of Set SelectRow = Union(SelectRow, CustomRange.Rows(i)). This will again change the output range, which doesn't seem to fit your desired output based on the description you gave.
To make everything fixed, also change the line Set rng = CustomRange.Cells(i, 1) to be Set rng = CustomRange.Rows(i)
I'm looping through a list of items most of which are numbers but occasionally I get a string.
I would like to skip the strings and go to the next row without breaking the loop.
I am defining the numbers as doubles so the strings give me a type mismatch errror.
I think I should be using some sort of IF test but am unsure how to tell VBA to skip the 'wrong' variables.
I have tried using variants to avoid the error but can't find an IF test to tell them apart.
If you want to get only explicit numbers excluding thereby also any text-formatted numbers (NumberFormat = "#"), which would be interpreted as Double anyway, you might code as follows checking for the variable type (VarType) as well as for the NumberFormat:
Sub ExplicitNumbersOnly()
Dim rng As Range
Set rng = Tabelle1.Range("A2:A10")
Dim i As Long
For i = 1 To rng.Rows.Count
Dim currCell As Range: Set currCell = rng.Cells(i, 1)
If VarType(currCell) = vbDouble And currCell.NumberFormat <> "#" Then
Debug.Print "OK:", currCell.Value
'... do something
'...
Else
'Debug.Print "Omitted: " & currCell.Address
End If
Next i
End Sub
Here is a tiny example of explicitly testing each value to see if it is "double compatible":
Sub NumCk()
Dim r As Range, rng As Range, v As Variant, d As Double
Set rng = Range("A1:A10")
For Each r In rng
v = r.Value
On Error Resume Next
d = CDbl(v)
If Err.Number = 0 Then
r.Offset(0, 1) = d / 2
Else
Err.Number = 0
End If
On Error GoTo 0
Next r
End Sub
It will reject a text value like "hello world" but accept a value like "1.2" as a text string.
I have a range consisting of two columns that the user would define thru Application.Inputbox method. I would store that as rng in the VBA to be copied then pasted later to some cells in Excel sheet. Before pasting, I would like to swap these two columns in rng. Is there a way to do that without a loop and without having to swap the actual original columns in the excel sheet?
So what I mean is something like this:
rng_swapped.Columns(1).Value = rng.Columns(2).Value
rng_swapped.Columns(2).Value = rng.Columns(1).Value
rng = rng_swapped
Use a variant array as an intermediate temporary storage so you can overwrite the original.
dim arr as variant
arr = rng_swapped.Columns(1).value
rng_swapped.Columns(1) = rng_swapped.Columns(2).Value
rng_swapped.Columns(2) = arr
from your narrative my understanding is that the range to paste to is different from the range to copy from.
so just go like this
Dim rng As Range
Set rng = Application.InputBox("Please select a range:", "Range Selection", , , , , , 8)
Dim rngToPaste As Range
Set rngToPaste = rng.Offset(, 20) ' just a guess...
rngToPaste.Columns(1).Value = rng.Columns(2).Value
rngToPaste.Columns(2).Value = rng.Columns(1).Value
How to use Jeeped's code
While playing around with the code... my curiosity fires away:
Why not:?
arr1 = oRng.Columns(1)
arr2 = oRng.Columns(2)
oRng.Columns(1) = arr2
oRng.Columns(2) = arr1
It turns out something (probably) the extra line makes the code slower (by about 10%).
I have a similar scenario and I know the range address. How should I use the code?
Sub SwapColumnsRange()
'Description
'In a specified range, swaps the first two columns i.e. the values of
'column(1) become the values of column(2) and the values of column(2) become
'the values of column(1).
'Arguments as constants
'cStrRange
'A string containing the Address of the range to be processed.
Const cStrRange As String = "A1:B50000" 'Your range address here.
Dim arr As Variant
Dim oRng As Range
Set oRng = Range(cStrRange)
If oRng.Areas.Count > 1 Then Exit Sub
If oRng.Columns.Count < 2 Then Exit Sub
'Slightly modified Jeeped's code
arr = oRng.Columns(1) '.Value
oRng.Columns(1) = oRng.Columns(2).Value
oRng.Columns(2) = arr
End Sub
I forgot to mention that I have more than two columns to be swapped!?
Sub ShiftColumnsRangeLeft()
'Description
'In a specified range with columns from 1 to 'n', shifts columns to the left
'i.e. the values of column(1) become the values of column(n), the values of
'column(2) become the values of column(1)... ...the values of column(n), the
'last column, become the values of column(n-1).
'Arguments as constants
'cStrRange
'A string containing the Address of the range to be processed.
Const cStrRange As String = "A1:I50000" 'Your range address here.
Dim arr As Variant
Dim oRng As Range
Dim i As Integer
Set oRng = Range(cStrRange)
If oRng.Areas.Count > 1 Then Exit Sub
If oRng.Columns.Count < 2 Then Exit Sub
For i = 1 To oRng.Columns.Count - 1 'ShiftColumnsRangeRight Difference
'Slightly modified Jeeped's code
arr = oRng.Columns(i) '.Value
oRng.Columns(i) = oRng.Columns(i + 1).Value
oRng.Columns(i + 1) = arr
Next
End Sub
You're a little off topic here, aren't you?
But not to this side, to the other side, please!?
Sub ShiftColumnsRangeRight()
'Description
'In a specified range with columns from 1 to 'n', shifts columns to the right
'i.e. the values of column(1) become the values of column(2), the values of
'column(2) become the values of column(3)... ...the values of column(n), the
'last column, become the values of column(1).
'Arguments as constants
'cStrRange
'A string containing the Address of the range to be processed.
Const cStrRange As String = "A1:I50000" 'Your range address here.
Dim arr As Variant
Dim oRng As Range
Dim i As Integer
Set oRng = Range(cStrRange)
If oRng.Areas.Count > 1 Then Exit Sub
If oRng.Columns.Count < 2 Then Exit Sub
For i = oRng.Columns.Count - 1 To 1 Step -1 'ShiftColumnsRangeLeft Difference
'Slightly modified Jeeped's code
arr = oRng.Columns(i) '.Value
oRng.Columns(i) = oRng.Columns(i + 1).Value
oRng.Columns(i + 1) = arr
Next
End Sub
I've changed my mind, I want to select a range and then run the macro to shift the columns!?
Sub ShiftColumnsSelectionRight()
'Description
'In a selection with columns from 1 to 'n', shifts columns to the right
'i.e. the values of column(1) become the values of column(2), the values of
'column(2) become the values of column(3)... ...the values of column(n), the
'last column, become the values of column(1).
Dim arr As Variant
Dim oRng As Range
Dim i As Integer
Set oRng = Selection
If oRng.Areas.Count > 1 Then Exit Sub
If oRng.Columns.Count < 2 Then Exit Sub
For i = oRng.Columns.Count - 1 To 1 Step -1 'ShiftColumnsRangeLeft Difference
'Slightly modified Jeeped's code
arr = oRng.Columns(i) '.Value
oRng.Columns(i) = oRng.Columns(i + 1).Value
oRng.Columns(i + 1) = arr
Next
End Sub
I've had it! Do the other two versions (Swap & ShiftLeft) yourself!
Remarks
These examples demonstrate how by making some simple modifications, the code can be used in different scenarios.
50000 is used to emphasize that the handling of the initial problem by looping through the range instead of using an array gets much, much slower as more rows are in the range.
The first If Statement ensures that the range is contiguous, and the second one ensures that there are at least two columns in the range.
Issues
I'm not completely sure that the '.value' part in the first line is not needed, but the code worked fine so far. On the other hand the '.value' part in the second line is needed or empty cells will be transferred.
When there are formulas in the range, they will be lost i.e. values will be transferred instead.
Can someone tell me how I can resize a column reference to the first row in a worksheet?
I get errors (for different reasons on both) which is understandable but still frustrating:
Attempt 1:
Dim Columns_To_Export as String
Columns_To_Export ="$B:$C,$E:$E"
Range(Columns_To_Export).Resize(1).Select
Attempt 2:
Dim Columns_To_Export as String
Columns_To_Export ="$B:$C,$E:$E"
Colulumns(Columns_To_Export).Resize(1).Select
I'm afraid I wasn't very attentive with my above response. Here is what I believe is a better try.
Private Sub SelectCells()
On Error Resume Next
Debug.Print CellsForExport("$B:$C, $E:$E, G").Address
End Sub
Function CellsForExport(ByVal Desc As String) As Range
' 15 Apr 2017
Dim Fun As Range, Rng As Range
Dim Spi() As String, Spj() As String
Dim i As Integer, j As Integer
Dim Cstart As Long, Cend As Long
Desc = Replace(Desc, "$", "")
Spi = Split(Desc, ",")
For i = 0 To UBound(Spi)
Spj = Split(Trim(Spi(i)), ":")
Cstart = Columns(Trim(Spj(0))).Column
Cend = Cstart
If UBound(Spj) Then Cend = Columns(Trim(Spj(1))).Column
With ActiveSheet.Rows(1)
Set Rng = .Range(.Cells(Cstart), .Cells(Cend))
End With
If Fun Is Nothing Then
Set Fun = Rng
Else
Set Fun = Application.Union(Fun, Rng)
End If
Next i
Set CellsForExport = Fun
End Function
The function CellsForExport returns a range as specified by the calling procedure SelectCells. The calling procedure in this case doesn't select the range. Instead it prints its address. That is for testing purposes. CellsForExport("$B:$C, $E:$E, G").Select will select the cells. You could also paste this range somewhere or manipulate it in any other way you can manipulate a range.
Note that you can omit the $ signs when specifying the columns. You also don't have to specify E:E to define a single column, but if someone does all that the macro will sort it out. Blank spaces don't matter, commas are of the essence.
Basically, Column is a range, not a string. This code will do the job.
Dim Rng As Range
With ActiveSheet
Set Rng = Application.Union(.Columns("B"), .Columns("C"), .Columns("E"))
End With
Rng.Select
I am looping through a row of cells and trying to assign the values in these cells to an array, but this is resulting in a Type Mismatch error. The relevant bits of my code are below:
Dim queryaddress As Range
Dim notoffsetnum As Integer
Dim anotherarrayofnumbers() As Integer
Dim c As Range
For Each queryaddress In worksheetname.Range("B2:B21")
Set queryrow = queryaddress.EntireRow
notoffsetnum = 0
For Each c In queryrow
If c.Interior.Color <> 192 And Not IsEmpty(c.Value) Then
notoffsetnum = notoffsetnum + 1
ReDim Preserve anotherarrayofnumbers(notoffsetnum)
anotherarrayofnumbers(notoffsetnum) = c.Value
'The above line errors
End If
Next c
Next queryaddress
A for each loop loops through a collection. You have a range called query row. You have a range called c. What you've done is loop through every RANGE in queryrow...which means c will just be query row.
You want
for each c in queryrow.cells
Also, be aware that's about as inefficient as possible since it's going to loop through all 65000 or so columns, instead of just the comparatively few that actually have data.
EDIT: I'm not sure why that's still getting you an error. You have other logical errors though. This executes for me (also, for the love of goodness, indenting!), if I throw in some data from B2:H21, for example:
Sub test()
Dim worksheetname As Worksheet
Set worksheetname = ActiveWorkbook.ActiveSheet
Dim queryaddress As Range
Dim notoffsetnum As Integer
Dim anotherarrayofnumbers() As Integer
Dim c As Range
For Each queryaddress In worksheetname.Range("B2:B21")
Dim queryrow As Range
Set queryrow = queryaddress.EntireRow
notoffsetnum = 0
For Each c In queryrow.Cells
If c.Interior.Color <> 192 And Not IsEmpty(c.Value) Then
notoffsetnum = notoffsetnum + 1
ReDim Preserve anotherarrayofnumbers(notoffsetnum)
anotherarrayofnumbers(notoffsetnum - 1) = c.Value
End If
Next c
Next queryaddress
Dim i As Integer
For i = 0 To UBound(anotherarrayofnumbers) - 1
Debug.Print anotherarrayofnumbers(i)
Next i
End Sub
One other problem that was easy to fix is that be default, VBA arrays are 0-based. They start at 0, and you were erroneously starting at 1. VBA won't throw an error, it'll just have element 0 be 0.
Your real problem is that after every row, you knock out the old array because notoffsetnum goes back to 0, and then you redim the array back to a size of 1. That throws away everything and at the end you've just got the last row. I ASSUME that's an error. Since this is something that comes up a lot, here's something that I think is a bit cleaner, and a little less brittle. The only assumption I make is that you start in B2, and that you have data going both down and to the right. If that's ever going to be a problem you can alter it a bit. I just think you'll find the range.end(xl...) methods a lifesaver. It takes you the cell you'd get if you pressed ctrl+arrow key, so it's a fast way to tease out the edges of ranges.
Sub BetterSolution()
Dim ws As Worksheet
Set ws = ActiveWorkbook.ActiveSheet
Dim firstCell As Range
Set firstCell = ws.Range("B2")
Dim lastCol As Integer
lastCol = firstCell.End(xlToRight).Column
Dim lastRow As Integer
lastRow = firstCell.End(xlDown).Row
Dim lastCell As Range
Set lastCell = ws.Cells(lastRow, lastCol)
Dim arr() As Integer
Dim rng As Range
Dim index As Integer
index = 0
For Each rng In ws.Range(firstCell, lastCell).Cells
index = index + 1
ReDim Preserve arr(index + 1)
arr(index) = rng.Value
Next rng
End Sub
The problematic bit of my code was this:
Dim anotherarrayofnumbers() As Integer
This led to an error on:
anotherarrayofnumbers(notoffsetnum) = c.Value
This was because some of my c.Value values were not actually integers.
One way to solve this is changing the array to the Variant type:
Dim anotherarrayofnumbers() As Variant
But this did not work for me as I later had to perform integer operations (such as WorksheetFunction.Quartile) on the array. Instead I simply applied formatting to those c.Value values that were not integer values, so as to filter them out of my array. This resolved my issues.
So my conditional on the If block now looks like this:
If c.Interior.Color <> 192 And c.Interior.Color <> 177 And Not IsEmpty(c.Value) Then
Where the additional interior color is what I formatted the non-integer values as.