Related
In excel I would like to copy the date from one sheet to another one using macro in a way that it will copy everything until row 9, then it will skip row 10 and copy row 11 and 12, and then skip one again.
So it should not copy row 10,13,16,19, etc..
I have the following code
Dim i As Integer
i = 9
J = 1
K = 9
Do While i < 5000
If J = 3 Then
J = 0
Sheets("sheet1").Select
Rows(i).Select
Selection.Copy
Sheets("sheet2").Select
Cells(K, 1).Select
ActiveSheet.Paste
K = K + 1
End If
J = J + 1
i = i + 1
Loop
This code is copying everything till the 8th row and then every 3rd, can somebody help me how to modify that code?
Fastest way will be to Copy >> Paste the entire rows once, according to your criteria.
You can achieve it by merging all rows that needs to be copies to a Range object, in my code it's CopyRng, and you do that by using Application.Union.
Code
Option Explicit
Sub CopyCertailRows()
Dim i As Long
Dim CopyRng As Range
Application.ScreenUpdating = False
With Sheets("sheet1")
' first add the first 8 rows to the copied range
Set CopyRng = .Rows("1:8")
For i = 9 To 5000
If (i / 3) - Int(i / 3) <> 0 Then ' don't add to copied range the rows that divide by 3 without a remainder
Set CopyRng = Application.Union(CopyRng, .Rows(i))
End If
Next i
End With
' copy >> paste in 1- line
CopyRng.Copy Destination:=Sheets("sheet2").Range("A9")
Application.ScreenUpdating = True
End Sub
You could simplify this massively by using If i < 10 Or (i - 1) Mod 3 <> 0 Then... which will select the rows you're interested in. Like so:
Dim i As Integer, j As Integer
j = 0
Dim sourceSht As Worksheet
Dim destSht As Worksheet
Set sourceSht = Sheets("Sheet1")
Set destSht = Sheets("Sheet2")
For i = 1 To 5000
If i < 10 Or (i - 1) Mod 3 <> 0 Then
j = j + 1
sourceSht.Rows(i).Copy destSht.Rows(j)
End If
Next
Personally, I'd turn screen updating and calculations off before running this and enable them again after to reduce the time needed to perform the loop.
Also, as Michał suggests, unless your dataset happens to be exactly 5,000 rows, you might want to 'find' the last row of data before starting to further reduce the time needed.
All necessary comments in code:
'declare all variables, be consistent with lower/uppercases, use Long instead of Integeer (its stored as long anyway)
'use meaningful variable names
Dim i As Long, copyUntil As Long, currentRow As Long
copyUntil = 9
currentRow = 1
'copy all rows until we reach 9th row
For i = 1 To copyUntil
Sheets("sheet1").Rows(i).Copy
Sheets("sheet2").Rows(currentRow).Paste
currentRow = currentRow + 1
Next
'now we will takes steps by 3, on every loop we will copy i-th row and next one, third will be omitted
'we also use currentRow variable to avoid empty rows in sheet2
'also, 5000 seems wrong, I'd recommend to determine last row, until which we will loop
'last row is often determined like Cells(Rows.Count, 1).End(xlUp).Row
For i = copyUntil + 2 To 5000 Step 3
Sheets("sheet1").Rows(i).Copy
Sheets("sheet2").Rows(currentRow).Paste
currentRow = currentRow + 1
Sheets("sheet1").Rows(i + 1).Copy
Sheets("sheet2").Rows(currentRow).Paste
currentRow = currentRow + 1
Next
This code will only paste values. Let me know if any questions or if you really, really need the formatting I can tweak it.
Sub DoCopy()
'This code is pretty much specifit to your request/question, it will copy 1-9, skip 10, 13, 16....
'i for the loop, x for the row that will not be added, y to paste on the second sheet
Dim i, x, y As Long, divn As Integer
For i = 1 To 5000
If i < 10 Then
y = y + 1
Sheets("Sheet1").Rows(i).Copy
Sheets("Sheet2").Range("A" & y).PasteSpecial ''Paste values only
ElseIf i >= 10 Then
x = i - 10
If x Mod 3 <> 0 Then
y = y + 1
Sheets("Sheet1").Rows(i).Copy
Sheets("Sheet2").Range("A" & y).PasteSpecial ''Paste values only
Else
'Do nothing
End If
End If
Next i
End Sub
Cant seem to figure out why my code is not showing output. New VBA programmer only know basics so any help would be helpful.
What I want is for Excel to start checking a specific column for a specific text1 and then start copying and pasting those values till it reaches text2. After that I want it to check the next fifth column in the same manner.
If you could suggest modifications to my code.
Without putting in a for loop for the column my code looks like this.
Private Sub CommandButton7_Click()
Dim x As Long, y As Long
Dim a As Long
y = 1 'starts with the first column
x = 1 'first row
a = 70 'this is the row where i want the data to be posted
If Cells(x, y).Value = "text1" Then 'check first for specific text
Do Until Cells(x, y).Value = "text2" 'stop here
Cells(a, y).Value = Cells(x, y).Value 'copy that data to new row
Cells(a, y + 1).Value = Cells(x, y + 1).Value 'and the column adjacent to it
x = x + 1
a = a + 1
Loop
Else
x = x + 1 'if not on that row then check the next row
End If
End Sub
Really hard to see what is going wrong here as your code should be doing what you want.
The only other thing that could throw your results is when you have different case ,as VBA will treat a string with an upper case character as being different, so you may not actually be entering the loop at all. And I am assuming that text1 is just a sample string for the question.
So comparing the string in lower case will ensure that if you have any upper case characters they will be compared correctly, using the LCase function should help with that.
Full code,
Private Sub CommandButton7_Click()
Dim x As Long, y As Long
Dim a As Long
y = 1 'starts with the first column
x = 1 'first row
a = 70 'this is the row where i want the data to be posted
If LCase(Cells(x, y).Value) = LCase("text1") Then 'check first for specific text
Do Until LCase(Cells(x, y).Value) = LCase("text2") 'stop here
Cells(a, y).Value = Cells(x, y).Value 'copy that data to new row
Cells(a, y + 1).Value = Cells(x, y + 1).Value 'and the column adjacent to it
x = x + 1
a = a + 1
Loop
Else: x = x + 1 'if not on that row then check the next row
End If
End Sub
Kind of hard to see the big picture but I think I produced the result you want with:
Sub FindText()
Dim textFound As Range
Dim x As Long, y As Long
Dim a As Long
y = 1 'starts with the first column
x = 0 'first row
a = 70 'this is the row where i want the data to be posted
Set textFound = ActiveSheet.Columns(y).Cells.Find("Text1")
Do Until textFound.Offset(x, 0).Value = "Text2"
Cells(a + x, y).Value = textFound.Offset(x, 0).Value
Cells(a + x, y + 1).Value = textFound.Offset(x, 1).Value
x = x + 1
Loop
End Sub
This code is far from perfect but should work in most circumstances.
I have a column A and a column B. In column A, I have (starting in A2) values that go from 1-150 (so ending in A151)
In column B, I have values. I want to get the first value that is above the value in cell Z2 and write out the corresponing value in the A column in cell B153 for column B. Last part is tricky. I only want to write this value if the following 4 values are also above the value in Z2. Is this possible to d?
If this is, I also have the same thing in columns C-Y
Better explanation:
I want to loop through columns B-Y
Inner loop from cells 2-151.
If B2>Z2 but also next 4 sequential cells (B3-B6)>Z2, then copy A2 to B153 and move to next column.
If B2 > Z2 but next 4 are not all > Z2, repeat process with B3.
If B2 < Z2, move to B3.
If none is true copy N/A to B153
Can this be done?
My first attempt:
=INDEX($A$2:$A$151,SUMPRODUCT(MATCH(1,--(B$2:B$151>$Z$2),0)),1)
This takes the first value though. I'm trying to think of a clever way to take the first value only if the second value also meets criteria. From there I'm sure I can expand to 3rd, 4th, 5th, etc.
There are a lot of ways to solve this, but in my opinion you need a nested loop in a user-defined function.
We can...
function get_Energy_Row(cellSearch as Range, staticValue as Single)
Dim cell1 as Single
get_Energy_Row = "N/A"
j = 1
col = cellSearch.Columns.Count
Do
cell1 = cellSearch(j, col)
If cell1 <= staticValue Then
'do nothing, function already set to "N/A"
Else
For i = 1 to 4
If cellSearch(i + j, col) > staticValue Then
get_Energy_Row = cellSearch(j,1)
Else
'do nothing, function already set to "N/A"
End If
Next i
End If
j = j + 1
Loop Until j >= cellSearch.Rows.Count - 3 Or get_Energy_Row <> "N/A"
End Function
Then call your UDF in cell C153 like this:
=get_Energy_Row($A2:B151,$Z$2), where you encompass the first column.
Note the dollar signs, this will ensure that your static check will always be Z2
The logic is that I default the cell to "N/A" until it finds a criteria that overwrites "N/A", in which case the loop is broken.
Your current formula might work for the single value case but I think it would be a littly clumsy to try to scale up. A couple quick ways to accomplish this via formula are:
=MIN(IF(COUNTIF(INDIRECT("B"&ROW(2:147)&":B"&ROW(6:151)),">"&Z2)=5,$A2:$A147,1E9))
And:
=MIN(IF((B2:B147>Z2)*(B3:B148>Z2)*(B4:B149>Z2)*(B5:B150>Z2)*(B6:B151>Z2),$A2:$A147,1E9))
Personally I think the latter is easier to read and drag through the spreadsheet (though the former could be modified to drag just as easily). The latter also avoids the volatile INDIRECT function. The first function takes 5 cell ranges at a time and counts the number of cells that match the criteria. If our count is 5, we have a match. This method is preferred if you are looking for larger sets of matches. The second formula just steps through the range checking basically r through r+4 where r is the current row. Both are array formulas that should be entered with CTRL + SHIFT + ENTER instead of just ENTER.
Something like this:
Sub OutputEnergy()
'y = Columns to check: 2-25
'x = Rows to check: 2-152
'z = check the next 4 cells
Dim x, y, z, check
'Clear the range where we store the #N/A or Energy Outputs
Range("B153:Y153") = vbNullString
For y = 2 To 25
For x = 2 To 152
If Cells(x, y) > Range("Z2") Then 'If value is greater than Z2
check = True 'Let's check the next 4
For z = 1 To 4 'If any of them fail
If Cells(x + z, y) < Range("Z2") Then
check = False 'The check fails
Exit For
End If
Next z
If check = True Then 'If the check doesn't fail
Cells(153, y) = Cells(x, 1) 'Set cell 153 to the energy level
Exit For
End If
End If
Next x 'If no energy level was set - #N/A
If Cells(153, y) = vbNullString Then Cells(153, y) = "#N/A"
Next y
End Sub
Edit: As a function:
Function Usage:
=OutputEnergy(Range, Threshold, [Number of cells to check], [Using Headers?])
Basically, give it the range to check, give it a threshold.
The number of cells to check afterwards is 4 by default.
To get the "Energy" it gets the row number (If using headers, it subtracts 1)
Function OutputEnergy(TheRange As Range, Threshold As Variant, Optional NextCells As Integer = 4, Optional OffsetForHeader As Boolean = True) As Variant
Dim c, x, check
For Each c In TheRange
If c.Value > Threshold Then
check = True
For x = 1 To NextCells
If c.Offset(x, 0) < Threshold Then
check = False
Exit For
End If
Next x
If check = True Then
OutputEnergy = IIf(OffsetForHeader, c.Row - 1, c.Row)
Exit Function
End If
End If
Next c
OutputEnergy = CVErr(xlErrNA)
End Function
Edit again - to output to all sheets:
OutputEnergyToSheet accepts a sheet as a parameter:
Sub OutputEnergyToSheet(TheSheet As String)
'y = Columns to check: 2-25
'x = Rows to check: 2-152
'z = check the next 4 cells
Dim x, y, z, check
'Clear the range where we store the #N/A or Energy Outputs
With Sheets(TheSheet)
.Range("B153:Y153") = vbNullString
For y = 2 To 25
For x = 2 To 152
If .Cells(x, y) > .Range("Z2") Then 'If value is greater than Z2
check = True 'Let's check the next 4
For z = 1 To 5 'If any of them fail
If .Cells(x + z, y) < .Range("Z2") Then
check = False 'The check fails
Exit For
End If
Next z
If check = True Then 'If the check doesn't fail
.Cells(153, y) = Int(.Cells(x, 1)) 'Set cell 153 to the energy level
Exit For
End If
End If
Next x 'If no energy level was set - #N/A
If .Cells(153, y) = vbNullString Then .Cells(153, y) = "#N/A"
Next y
End With
End Sub
OutputEnergyToAllSheets loops through each sheet and calls the new sub:
Sub OutputEnergyToAllSheets()
Dim w
For Each w In ThisWorkbook.Worksheets
If Not InStr(w.Name, "Total") > 0 And Not InStr(w.Name, "eV") > 0 Then
OutputEnergyToSheet w.Name
End If
Next w
End Sub
I have a spreadsheet with 50K values on it.
I want it a code to go through every value and check to see if it ends in a 5 or 0 and if it doesn't not to round to the nearest of the two.
I tried this as my code
Sub Round_flow()
Dim nxtRow As Long, found As Boolean, i As Long, minus As Long, plus As Long, equal As Long, cell As Boolean, f As Integer
nxtRow = 2
found = False
i = Sheet1.Cells(nxtRow, 2)
minus = -2
equal = 0
While Not found 'finds last used row
If (Cells(nxtRow, 2) = "") Then
found = True
Else
nxtRow = nxtRow + 1
End If
Wend
For f = 2 To i
For minus = -2 To 168 Step 5
If ActiveCell.Value <> equal Then
While Not cell
plus = minus + 4
equal = minus + 2
If minus <= ActiveCell.Value <= plus Then
Sheet1.Cells(i, 2).Value = equal
cell = True
End If
Wend
End If
Next minus
Next f
Essentially what I was trying to do is say here is the last row, i want to check every value from i to last filled row to see if it falls between any plus and minus value (+-2 of the nearest 5 or 0) then have whatever activecell.value be replaced by the 0 or 5 ending digit 'equal' which changes with each iteration.
Ok, that seems way too complicated. To round to 5, you just multiply by 2, round, then divide by 2. Something like this will do the trick:
Dim NumberToBeRounded as Integer
Round(NumberToBeRounded *2/10,0)/2*10
*2 and /2 to get it to be rounded to 5, and /10 *10 to make the round function round for less than 0 decimals.
(I have to admit, I don't really understand what your code is trying to do, I hope I didn't completely misunderstand your needs.)
This should do the trick:
Sub Round_flow()
For f = 2 To Cells(1, 2).End(xlDown).Row
Cells(f, 2).Value = Round(Cells(f, 2).Value * 2 / 10) / 2 * 10
Next
End Sub
Cells(1, 2).End(xlDown).Row finds the last used cell, unless you have no data; if that can happen, add some code to check if you have at least 2 rows. Or you can use the Usedrange and SpecialCells(xlLastCell) combo to find the last used row of your table...
Another way:
Sub RoundEm()
Dim wks As Worksheet
Dim r As Range
Dim cell As Range
Set wks = ActiveSheet ' or any other sheet
On Error Resume Next
Set r = wks.Cells.SpecialCells(xlCellTypeConstants, xlNumbers)
On Error GoTo 0
If Not r Is Nothing Then
For Each cell In r
cell.Value2 = Round(cell.Value2 / 5, 0) * 5
Next cell
End If
End Sub
I have a code that works, but I want to add some more functionality to it. It currently does what it is supposed to do, and has sped up some processes, but now I think it can be sped up even more. I am using the solution that I marked as answered here: Using VBA to get a threshold value
But
I have this code:
Sub OutputEnergyToAllSheets()
Dim w
For Each w In ThisWorkbook.Worksheets
If Not InStr(w.Name, "Total") > 0 And Not InStr(w.Name, "eV") Then
OutputEnergyToSheet w.Name
End If
Next w
End Sub
Sub OutputEnergyToSheet(TheSheet As String)
'y = Columns to check: 2-25
'x = Rows to check: 2-152
'z = check the next 4 cells
Dim x, y, z, check
'Clear the range where we store the #N/A or Energy Outputs
With Sheets(TheSheet)
.Range("B153:Y153") = vbNullString
For y = 2 To 25
For x = 2 To 152
If .Cells(x, y) > .Range("Z2") Then 'If value is greater than Z2
check = True 'Let's check the next 4
For z = 1 To 30 'If any of them fail
If .Cells(x + z, y) < .Range("Z2") Then
check = False 'The check fails
Exit For
End If
Next z
If check = True Then 'If the check doesn't fail
.Cells(153, y) = Int(.Cells(x, 1)) 'Set cell 153 to the energy level
Exit For
End If
End If
Next x 'If no energy level was set - #N/A
If .Cells(153, y) = vbNullString Then .Cells(153, y) = ""
Next y
End With
End Sub
But the line that says:
for z = 1 to 30
I am having to change from 0 to 100 in increments of 1. It outputs these values where it should on all worksheets and then I go to the sub and increase value and repeat. The values are output in each worksheet except a few in row 153. Is there a way to have 0 be in row 153, 1 be in 154, 2 in 155, etc up to 100? I understand if this is not possible, but it would me a TON of time, because I have to go through this process for many workbooks. If this can be done it will save me several monotonous hours of busy-work. Anyways, thanks for reading.
For this first code block, I tried to stay with the general structure of the code in your question. I could have for example swapped out the innermost two For loops for a single While loop. That would be more efficient but requires a significant logic change. I did make some changes though. I set everything to "N/A" at the beginning instead of the end and I added a condition to the last If statement. To implement your new functionality of checking for variable numbers of consecutive cells, I included another For loop with counter k around the For loop with counter z and made the end point of z dependent on k. We print out to row 152 + k.
Sub OutputEnergyToSheet(TheSheet As String)
'y = Columns to check: 2-25
'x = Rows to check: 2-152
'k = number of matches in a row to find
'z = check the next (k - 1) cells
Dim x, y, z, check, k
'Clear the range where we store the N/A or Energy Outputs
With Sheets(TheSheet)
.Range("B153:Y252") = "N/A"
For y = 2 To 25
For x = 2 To 151
If .Cells(x, y) > .Range("Z2") Then 'If value is greater than Z2
For k = 1 To 100
check = True 'Let's check the next k - 1
For z = 1 To k - 1 'If any of them fail
If .Cells(x + z, y) <= .Range("Z2") Then
check = False 'The check fails
Exit For
End If
Next z
If check = True And .Cells(152 + k, y) = "N/A" Then
.Cells(152 + k, y) = Int(.Cells(x, 1))
End If
Next k
End If
Next x
Next y
End With
End Sub
Before I did all this, I threw together my own method which is cleaner and runs much faster. The code below steps down the rows and maintains a running count of how many consecutive matches it has found. It eliminates a lot of checks because it only checks any given cell once. Down to 2 total loops! The code above was checking a cell many times over in the inner loops. The below code could probably be better by maintaining the values in an array (read/write in Excel is slow) and/or maintaining a counter of the maximum length I have already achieved for the current column. I stored most of my numbers as variables that can be easily and confidently modified.
Sub EfficientEnergy(ws As Worksheet)
Dim r As Integer, c As Integer, ctr As Integer
Dim compVal As Double
Dim maxRow As Integer, maxCol As Integer, maxConsecutive As Integer
maxRow = 151
maxCol = 25
maxConsecutive = 100
compVal = ws.Cells(2, 26).Value
ws.Range(ws.Cells(maxRow + 2, 2), ws.Cells(maxRow + maxConsecutive + 1, maxCol)).Value = "N/A"
For c = 2 To maxCol
ctr = 0
For r = 2 To maxRow
If ws.Cells(r, c).Value > compVal Then
ctr = ctr + 1
If ws.Cells(maxRow + 1 + ctr, c).Value = "N/A" Then
ws.Cells(maxRow + 1 + ctr, c).Value = ws.Cells(r - ctr + 1, 1).Value
End If
Else
ctr = 0
End If
Next r
Next c
End Sub
The code I am using to call these methods in my testing is (just comment out whichever one you aren't using):
Public Sub GetConsecutiveVals()
'OutputEnergyToSheet ("Sheet1")
Call EfficientEnergy(ActiveWorkbook.Worksheets("Sheet1"))
End Sub
Or to run on every worksheet in active workbook (untested):
Public Sub GetConsecutiveVals()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
'OutputEnergyToSheet (ws.Name)
Call EfficientEnergy(ws)
Next ws
End Sub
Place all your code in a module in a workbook. Open your workbook with data in Sheet1 (or change the code above to your sheet name). Hit Alt + F8 and then run the GetConsecutiveVals routine. If you don't see that method in the dialog window, make sure the workbook with the code and the workbook with your data are in the same Excel application window
#jack This is how i read this code. Check all cells from Column 2 - 25, Rows 2 - 152, if one of them is greater than Z2, Enter Zloop, Begin checking the next 30 rows, to see if any of those are smaller. if so do nothing, if one is, in cell 153,y = Column 1 same row, go to next column ..question: Why have Z only check 30? why not have it check the remaining 152 ...z= 1 to 152 - x ?
in any case i think this is what you want to do, create another variable say
DIM Result As Integer
Result = 153
''then below
If check = True Then 'If the check doesn't fail
''.Cells(153, y) = Int(.Cells(x, 1)) 'Set cell 153 to the energy level
.Cells(Result, y) = Int(.Cells(x, 1)) 'Set cell 153 to the energy level
Result = Result + 1
EXIT FOR
Why use three loops when one would do?
Sub OutputEnergyToAllSheets()
Dim w as worksheet
For Each w In ThisWorkbook.Worksheets
If Not InStr(1, w.Name, "Total") > 0 And Not InStr(1, w.Name, "eV") Then
OutputEnergyToSheet w.Name
End If
Next w
End Sub
Sub OutputEnergyToSheet(TheSheet As String)
Dim check as Boolean
Dim rng as Range
Dim c
Dim ELevel as integer
'Clear the range where we store the #N/A or Energy Outputs
With Sheets(TheSheet)
' set all cells in row 153 = 0
.Range("B153:Y153").value = 0
ELevel = .cells(2,26)
' Your range
set rng = .Range(.Cells(2,2), .cells(25, 153))
' Loop through all cells in range
For each c in rng.cells
' If value is greater then Z2 and respective column in row 153 = 0 and cell is not in 153 then change 153 = respective row column 1
If c.value > ELevel and .cells(153, c.column) = 0 and c.row <> 153 Then
.cells(153,c.column) = .cells(c.row, 1)
' If value is less then Z2 and cell is not in 153 then change 153 = 0
elseif c.value < ELevel and c.row <> 153 then
.cells(153, c.column) = 0
' Clean up - if cell is in row 153 and value = 0 then change to "N/A"
elseif c.row = 153 and c.value = 0 then
c.value = "N/A"
end if
Next c
End With
End Sub
Please let me know if I've misunderstood