In VBA I try to run a loop with an if statement. The loop is set to run a row at a time for a range (wks "Data", B7:J25).
For each row if the value at column C7:C25 is 1, I would like to copy that row (e.g. B7:J7) and insert it at the worksheet "temp" one at a time.
I have tried various codes, for example:
Sub start()
Dim i As Integer
Dim wsData, wsCalcAndOutput, wsTemp As Worksheet
For i = 1 To 25
If Cells((7 + i), 3) = "1" Then
Worksheets("Data").Range("B7:J7").Copy _
Worksheets("temp").Range("B7:J7")
End If
Next
End Sub
But then I can only copy and paste the first row of the range. Alternatively, I found this procedure at stackoverflow, but I can't seem to be able to paste what I copy at each iteration:
Dim wsData, wsCalcAndOutput As Worksheet
Dim rSPX, rSX5E, rNKY, rUKX, rSMI, rEEMUP, testData As Range
Sub start()
Dim i As Integer
For i = 1 To 25
If Cells((7 + i), 3) = "1" Then
With ActiveSheet
.Range(.Cells((7 + i), 2), .Cells((7 + i), 10)).Copy
End With
End If
Next
End Sub
Is this the right way to do so or is there a more efficient way?
Also - in the dataset the criteria for the if statement is actually a string called either "TRUE" or "FALSE". Can an if statement use a string as a signal instead of "1"?
All the best,
Christoffer
As BigBen says, using AutoFilter would be quicker but here is one way of doing this with a loop. Have added a few comments which hopefully explain the basics.
One problem with your code was that you weren't changing the destination cells so they would continually be overwritten.
Sub start()
Dim i As Long 'better than integer
Dim n As Long: n = 7
Dim wsData As Worksheet, wsCalcAndOutput As Worksheet, wsTemp As Worksheet 'specify each type
With Worksheets("Data")
For i = 7 To 25 'change as appropriate
If .Cells(i, 3) = 1 Then 'no need for quotes
Range(.Cells(i, "B"), Cells(i, "J")).Copy _
Worksheets("temp").Cells(n, "B") 'start at row 7?
n = n + 1 'update so that we don't overwrite next time
End If
Next
End With
End Sub
Related
This is a code that goes through the cells in column B in sheet2. If it finds a value that is not a date in column B, then it copies it, pastes it another sheet called 'errors' and then deletes that row from Sheet2. Whenever I try to run this, however, I get a 'Compile Error: Sub or function not defined'. I saw some other posts on this, but nothing mentioned there seemed to work for me.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheet("Errors").CountA("A1:A100")
For Each i In Worksheet("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheet("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub
There are a few other errors/changes that could be made within the script
Add s to Worksheet
Use Option Explicit at top of code
Application.WorksheetFunction.CountA
Add range as argument to Counta i.e. Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Ensure correct ranges being worked with by wrapping in With Worksheets("Sheet2")
Determine last row by coming up from bottom of sheet with .Cells(.Rows.Count, "A").End(xlUp).Row, or you could end up looping to bottom of sheet
Correct syntax for delete line: i.EntireRow.Delete
You can put copy paste on one line: .Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
Be wary of using End(xlToRight) in cases of potentially ending up at far right of sheet.
Optimize code by switching some things off e.g. prevent repaint by switching off screen-updating during looping
Gather ranges to delete with Union and delete in 1 go or loop backwards to delete
VBA:
Option Explicit
Public Sub removeerrors()
Dim i As Range, x As Double, loopRange As Range, lastRow As Long, unionRng As Range
x = Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Application.ScreenUpdating = False
With Worksheets("Sheet2")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set loopRange = .Range("A2:A" & lastRow)
If lastRow = 1 Then Exit Sub
For Each i In loopRange
If Not IsDate(i.Offset(0, 1)) Then
.Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, i)
Else
Set unionRng = i
End If
End If
Next i
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
You just need to change Worksheet to Worksheets with 's' at the end.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
For Each i In Worksheets("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheets("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub
use fully qualified range references
loop backwards when deleting rows
update target sheet pasting row index
as follows
Option Explicit
Sub removeerrors()
Dim iRow As Long
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
With Worksheets("Sheet2") ' referecne "Sheet2" sheet
With .Range(.Range("A2"), .Range("A2").End(xlDown)) ' reference referenced sheet range from cell A2 down to next not empty one
For iRow = .Rows.Count To 1 Step -1 ' loop reference range backwards from its last row up
If Not IsDate(.Cells(iRow, 2)) Then ' if referenced range cell in column B current row is not a date
.Range(.Cells(iRow, 1), .Cells(iRow, 1).End(xlToRight)).Copy Destination:=Worksheets("Errors").Range("A1").Offset(x, 0) ' copy referenced range current row spanning from column A to next not empty column and paste it to sheet "Errors" column A row x
x = x + 1 ' update offset
.Rows(1).EntireRow.Delete ' delete referenced range current row
End If
Next
End With
End With
End Sub
I am trying to run a macro on 3 different ranges, one after another. Once the range is selected, the code works just fine (where variables F and L are defined). I would like to set r1-r3 as Ranges I need and then use a string variable to concatenate the range numbers together. This code works, but doesn't provide the starting and ending row number in the range selected. This is vital because it tells the "TableCalc" macro when to start and stop the code. I would then like to move on to the next range. Thanks for your help.
Sub TestRangeBC()
WS.Select
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim rngx As String
Dim num As Integer
Dim rng As Range
Set r1 = WS.Range("ONE")
Set r2 = WS.Range("TWO")
Set r3 = WS.Range("THREE")
For num = 1 To 3
rngx = "r" & num
Set rng = Range(rngx)
Dim F As Integer
Dim L As Integer
F = rng.Row + 1
L = rng.Row + rng.Rows.Count - 2
Cells(F, 8).Select
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
'INSERT SITUATIONAL MACRO
Call TableCalc
WS.Select
ActiveCell.Offset(1, 0).Select
Loop
Next num
End Sub
This is not the answer (as part of your code and what you are trying to achieve is unclear yet), but it is a "cleaner" and more efficient way to code what you have in your original post.
Option Explicit
Dim WS As Worksheet
Your original Sub shorten:
Sub TestRangeBC()
' chanhe WS to your Sheet name
Set WS = Sheets("Sheet1")
Call ActiveRange("ONE")
Call ActiveRange("TWO")
Call ActiveRange("THREE")
End Sub
This Sub gets the Name of the Named Range (you set in your workbook) as a String, and sets the Range accordingly.
Sub ActiveRange(RangeName As String)
Dim Rng As Range
Dim F As Integer
Dim L As Integer
Dim lRow As Long
With WS
Set Rng = .Range(RangeName)
' just for debug purpose >> to ensure the right Range was passed and set
Debug.Print Rng.Address
F = Rng.Row + 1
L = Rng.Row + Rng.Rows.Count - 2
lRow = F
' what you are trying to achieve in this loop is beyond me
Do While .Cells(F, 8) <> "" And .Cells(lRow, 8).Row <= L
Debug.Print .Cells(lRow, 8).Address
'INSERT SITUATIONAL MACRO
' Call TableCalc
' not sure you need to select WS sheet again
WS.Select
lRow = lRow + 1
Loop
End With
End Sub
What are you trying to test in the loop below, what are the criteria of staying in the loop ?
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
it's really hard to tell what you may want to do
but may be what follows can help you clarifying and (hopefully) doing it!
first off, you can't "combine" variable names
So I'd go with an array of named ranges names (i.e. String array) to be filled by means of a specific sub:
Function GetRanges() As String()
Dim ranges(1 To 3) As String
ranges(1) = "ONE"
ranges(2) = "TWO"
ranges(3) = "THREE"
GetRanges = ranges
End Function
so that you can clean up your "main" sub code and keep only more relevant code there:
Sub TestRangeBC()
Dim r As Variant
Dim ws As Worksheet
Set ws = Worksheets("Ranges") '<--| change "Ranges" to your actual worksheet name
For Each r In GetRanges() '<--| loop through all ranges names
DoIt ws, CStr(r) '<--| call the range name processing routine passing worksheet and its named range name
Next r
End Sub
the "main" sub loops through the named ranges array directly collected from GetRanges() and calls DoIt() to actually process the current one:
Sub DoIt(ws As Worksheet, rangeName As String)
Dim cell As Range
Dim iRow As Long
With ws.Range(rangeName) '<--| reference the passed name passed worksheet named range
For iRow = .Rows(2).Row To .Rows(.Rows.Count - 2).Row '<--| loop through its "inner" rows (i.e. off 1st and last rows)
Set cell = ws.Cells(iRow, 8) '<--| get current row corresponding cell in column "F"
If cell.value = "" Then Exit For '<--| exit at first blank column "F" corresponding cell
TableCalc cell '<-- call TableCalc passing the 'valid' cell as its parameter
Next iRow
End With
End Sub
I have looked through the other posts about this and have tried adapted the strategies that were recommend by using Set ActiveWorkbook and Set Active Worksheet and I still get the same error. I hope another set of eyes can help out as I am still very new to VBA and I am not all that comfortable with it yet.
Basically the idea is to copy the cells from column f to column j as values as long as the cells of F do not match the cells of J. I get the row count of column E and use that as my count in the for loop.
Code is here:
Private Sub CalculateRewards_Click()
CopyPaste
End Sub
Sub CopyPaste()
Dim n As Integer
Dim i As Integer
n = Sheets("Calculate").Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
i = n
For Counter = 1 To n
Set curCell = Sheets("Calculate").Range("F2:F" &i)
If "$F" &i <> "$J" &i Then
Sheets("Calculate").Range("$F:$F" &i).Copy
Sheets("Calculate").Range("$J:$J" &i).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
i = i + 1
Next Counter
End Sub
Thanks for the help
Also Edit:
Link to Excel Sheet that has a before page, after first transaction sheet ,and a after second transaction sheet: https://www.dropbox.com/s/n2mn0zyrtoscjin/Rewards.xlsm
CHange this:
Set curCell = Sheets("Calculate").Range("F2:F" &i)
If "$F" &i <> "$J" &i Then
Sheets("Calculate").Range("$F:$F" &i).Copy
Sheets("Calculate").Range("$J:$J" &i).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
To this:
Set curCell = Sheets("Calculate").Range("F2:F" & i)
If curCell <> Sheets("Calculate").Range("$J" & i) Then
Sheets("Calculate").Range("$J:$J" &i).Value = curCell.Value
End If
May need to do some more teaking as I notice you're working with SpecialCells which essentially filters the range, so iterating For i = 1 to n... probably does not work. Maybe something like:
Dim rngCalc as Range
Set rngCalc = Sheets("Calculate").Range("E:E").Cells.SpecialCells(xlCellTypeConstants)
For each curCell in rngCalc.Cells
If curCell <> curCell.Offset(0, 4) Then
curCell.Offset(0, 4).Value = curCell.Value
End If
Next
EDIT: this sub will calculate the points for the last transaction (identified as the furthest-right column containing transactions) and write them down in column C.
Option Explicit
Sub UpdateCurrentPurchase()
Dim CalcSheet As Worksheet
Dim LastTransRange As Range, TargetRange As Range
Dim LastTransCol As Long, LastTransRow As Long
Dim PurchaseArray() As Variant
Dim Points As Long, Index As Long
'set references up-front
Set CalcSheet = ThisWorkbook.Worksheets("Calculate")
With CalcSheet
LastTransCol = .Cells(2, .Columns.Count).End(xlToLeft).Column '<~ find the last column
LastTransRow = .Cells(.Rows.Count, LastTransCol).End(xlUp).Row
Set LastTransRange = .Range(.Cells(2, LastTransCol), .Cells(LastTransRow, LastTransCol))
Set TargetRange = .Range(.Cells(2, 6), .Cells(LastTransRow, 6)) '<~ column F is the Current Purchase Col
LastTransRange.Copy Destination:=TargetRange '<~ copy last transactions to Current Purchase Col
End With
'pull purchases into a variant array
PurchaseArray = TargetRange
'calculate points
For Index = 1 To LastTransRow
Points = Int(PurchaseArray(Index, 1) / 10) '<~ calculate points
CalcSheet.Cells(Index + 1, 3) = Points '<~ write out the points amount in col C
Next Index
End Sub
ORIGINAL RESPONSE: I think the below will get you where you're going. That being said, it seems like simply overwriting column J with column F (as values) might be the fastest way to an acceptable answer, so if that's the case we can re-work this code to be much quicker using Range objects.
Option Explicit
Private Sub CalculateRewards_Click()
CopyPaste
End Sub
Sub CopyPaste()
Dim LastRow As Long, Counter As Long
Dim cSheet As Worksheet '<~ add a worksheet reference to save some typing
'set references up front
Set cSheet = ThisWorkbook.Worksheets("Calculate")
With cSheet
LastRow = .Range("E" & .Rows.Count).End(xlUp).Row '<~ set loop boundary
'loop that compares the value in column 6 (F) to the value in
'column 10 (J) and writes the value from F to J if they are not equal
For Counter = 1 To LastRow
If .Cells(Counter, 6).Value <> .Cells(Counter, 10).Value Then
.Cells(Counter, 10) = .Cells(Counter, 6)
End If
Next Counter
End With
End Sub
i'm trying to make a macro which:
goes through a table
looks if value in column B of that table has a certain value
if it has, copy that row to a range in an other worksheet
The result is similar to filtering the table but I want to avoid hiding any rows
I'm kinda new to vba and don't really know where to start with this, any help much appreciated.
That is exactly what you do with an advanced filter. If it's a one shot, you don't even need a macro, it is available in the Data menu.
Sheets("Sheet1").Range("A1:D17").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("G1:G2"), CopyToRange:=Range("A1:D1") _
, Unique:=False
Try it like this:
Sub testIt()
Dim r As Long, endRow as Long, pasteRowIndex As Long
endRow = 10 ' of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1
For r = 1 To endRow 'Loop through sheet1 and search for your criteria
If Cells(r, Columns("B").Column).Value = "YourCriteria" Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
End Sub
Selects are slow and unnescsaary. The following code will be far faster:
Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
For i = 2 To ws1.Range("B65536").End(xlUp).Row
If ws1.Cells(i, 2) = "Your Critera" Then ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
Next i
End Sub
you are describing a Problem, which I would try to solve with the VLOOKUP function rather than using VBA.
You should always consider a non-vba solution first.
Here are some application examples of VLOOKUP (or SVERWEIS in German, as i know it):
http://www.youtube.com/watch?v=RCLUM0UMLXo
http://office.microsoft.com/en-us/excel-help/vlookup-HP005209335.aspx
If you have to make it as a macro, you could use VLOOKUP as an application function - a quick solution with slow performance - or you will have to make a simillar function yourself.
If it has to be the latter, then there is need for more details on your specification, regarding performance questions.
You could copy any range to an array, loop through this array and check for your value, then copy this value to any other range. This is how i would solve this as a vba-function.
This would look something like that:
Public Sub CopyFilter()
Dim wks As Worksheet
Dim avarTemp() As Variant
'go through each worksheet
For Each wks In ThisWorkbook.Worksheets
avarTemp = wks.UsedRange
For i = LBound(avarTemp, 1) To UBound(avarTemp, 1)
'check in the first column in each row
If avarTemp(i, LBound(avarTemp, 2)) = "XYZ" Then
'copy cell
targetWks.Cells(1, 1) = avarTemp(i, LBound(avarTemp, 2))
End If
Next i
Next wks
End Sub
Ok, now i have something nice which could come in handy for myself:
Public Function FILTER(ByRef rng As Range, ByRef lngIndex As Long) As Variant
Dim avarTemp() As Variant
Dim avarResult() As Variant
Dim i As Long
avarTemp = rng
ReDim avarResult(0)
For i = LBound(avarTemp, 1) To UBound(avarTemp, 1)
If avarTemp(i, 1) = "active" Then
avarResult(UBound(avarResult)) = avarTemp(i, lngIndex)
'expand our result array
ReDim Preserve avarResult(UBound(avarResult) + 1)
End If
Next i
FILTER = avarResult
End Function
You can use it in your Worksheet like this =FILTER(Tabelle1!A:C;2) or with =INDEX(FILTER(Tabelle1!A:C;2);3) to specify the result row. I am sure someone could extend this to include the index functionality into FILTER or knows how to return a range like object - maybe I could too, but not today ;)
I'm just beginning to dive into VBA and I've hit a bit of a roadblock.
I have a sheet with 50+ columns, 900+ rows of data. I need to reformat about 10 of those columns and stick them in a new workbook.
How do I programmatically select every non-blank cell in a column of book1, run it through some functions, and drop the results in book2?
I know I'm am very late on this, but here some usefull samples:
'select the used cells in column 3 of worksheet wks
wks.columns(3).SpecialCells(xlCellTypeConstants).Select
or
'change all formulas in col 3 to values
with sheet1.columns(3).SpecialCells(xlCellTypeFormulas)
.value = .value
end with
To find the last used row in column, never rely on LastCell, which is unreliable (it is not reset after deleting data). Instead, I use someting like
lngLast = cells(rows.count,3).end(xlUp).row
The following VBA code should get you started. It will copy all of the data in the original workbook to a new workbook, but it will have added 1 to each value, and all blank cells will have been ignored.
Option Explicit
Public Sub exportDataToNewBook()
Dim rowIndex As Integer
Dim colIndex As Integer
Dim dataRange As Range
Dim thisBook As Workbook
Dim newBook As Workbook
Dim newRow As Integer
Dim temp
'// set your data range here
Set dataRange = Sheet1.Range("A1:B100")
'// create a new workbook
Set newBook = Excel.Workbooks.Add
'// loop through the data in book1, one column at a time
For colIndex = 1 To dataRange.Columns.Count
newRow = 0
For rowIndex = 1 To dataRange.Rows.Count
With dataRange.Cells(rowIndex, colIndex)
'// ignore empty cells
If .value <> "" Then
newRow = newRow + 1
temp = doSomethingWith(.value)
newBook.ActiveSheet.Cells(newRow, colIndex).value = temp
End If
End With
Next rowIndex
Next colIndex
End Sub
Private Function doSomethingWith(aValue)
'// This is where you would compute a different value
'// for use in the new workbook
'// In this example, I simply add one to it.
aValue = aValue + 1
doSomethingWith = aValue
End Function
If you are looking for the last row of a column, use:
Sub SelectFirstColumn()
SelectEntireColumn (1)
End Sub
Sub SelectSecondColumn()
SelectEntireColumn (2)
End Sub
Sub SelectEntireColumn(columnNumber)
Dim LastRow
Sheets("sheet1").Select
LastRow = ActiveSheet.Columns(columnNumber).SpecialCells(xlLastCell).Row
ActiveSheet.Range(Cells(1, columnNumber), Cells(LastRow, columnNumber)).Select
End Sub
Other commands you will need to get familiar with are copy and paste commands:
Sub CopyOneToTwo()
SelectEntireColumn (1)
Selection.Copy
Sheets("sheet1").Select
ActiveSheet.Range("B1").PasteSpecial Paste:=xlPasteValues
End Sub
Finally, you can reference worksheets in other workbooks by using the following syntax:
Dim book2
Set book2 = Workbooks.Open("C:\book2.xls")
book2.Worksheets("sheet1")
For me the best way to proceed was to:
Create a new Excel Table
AutoFilter it by the parameter Criterial:="<>"
An example of the code would be:
Sub ExampleFilterCol()
' Create a Table
Dim ws As Worksheet
Dim rg As Range
Set ws = ActiveSheet
Set rg = ws.Range("A1").CurrentRegion
ws.ListObjects.Add(xlSrcRange, rg, , xlYes).Name = "myNonRepeatedTableName"
' Filter the created table
Dim Io As ListObject
Dim iCol As Long
' Set reference to the first Table on the sheet
' That should be the recently created one
Set lo = Sheets("Totalinfo").ListObjects(1)
' Set filter field
iCol = lo.ListColumns("yourColumnNameToFilter").Index
' Non-blank cells – use NOT operator <>
lo.Range.AutoFilter Field:=iCol, Criteria1:="<>"
End Sub
This might be completely off base, but can't you just copy the whole column into a new spreadsheet and then sort the column? I'm assuming that you don't need to maintain the order integrity.