Im trying to write a macro that filters the column F from second to last row to check if the values in the column are numeric and if the length is 5. A diffrent length is allowed if the value in the column G on the same row contains "TEST".If the value doesnt meet the criteria the row should be deleted. The macro seems to work but I need to start it multiple times to filter all the values.
here is the macro:
Sub Makro1()
Dim lrow As Long
lrow = Cells(Cells.Rows.Count, "F").End(xlUp).Row
Dim Rng As Range
Set Rng = Range("F2:F" & lrow)
For Each cell In Rng
If Not IsNumeric(cell) Or (Len(cell) <> 5 And
InStr(UCase(cell.Offset(0, 1).Value), "TEST") = 0) Then
cell.EntireRow.Delete
End If
Next
End Sub
Try this code, it uses backward loop, which is recommended when iterating over colletion, that we delete from:
Sub Makro1()
Dim lrow As Long, i As Long, cellValue As String
lrow = Cells(Rows.Count, "F").End(xlUp).Row
For i = lrow To 2 Step -1
cellValue = Cells(i, "F").Value
If Not (IsNumeric(cellValue) And Len(cellValue) = 5) And Cells(i, "G").Value = "TEST" Then
Rows(i).Delete
End If
Next
End Sub
Related
I'm currently creating an automation that will separate the fruits for each store. Basically my file looks like below:
What I need to do is to transfer all fruits of Store X and B to column F (all fruits from different stores). The number of stores could grow as well as the fruits.
I have the code below, however, it only gets the first fruit and jump in to the next store already.
Sub test()
Dim i, lastrow As Long
lastrow = ActiveSheet.Cells(Worksheets(1).Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
Cells(i, 1).Select
If Cells(i, 1).Value <> "" Then
Cells(i, 6) = Cells(i, 4).Value
End If
Next i
End Sub
I'm thinking to add another lastrow count for the fruits, however, it just continues until the last row of column D.
I suggest the following:
Option Explicit
Public Sub CopyFruitsIntoStores()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet 'if this code is for a specific sheet only then better define a sheet like Thisworkbook.Worksheets("NameOfSheet")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row 'find last row in col D it is longer than A
Dim iStore As Long 'to count the stores
Dim iRow As Long
For iRow = 2 To LastRow
If ws.Cells(iRow, 1).Value <> vbNullString Then 'if a new store begins
iStore = iStore + 1
'Use following line to write the headers for the stores
ws.Cells(1, 5 + iStore).Value = ws.Cells(iRow, 1).Value & " (Fruits)"
End If
ws.Cells(iRow, 5 + iStore).Value = ws.Cells(iRow, 4).Value
Next iRow
End Sub
Count the stores in iStore and use that store count to determine the destination column.
Also note that you need to determine the LastRow in column D not A. Column D has more entries than A has. If you use A's last row it stops too early.
The following should do what you are requesting, I check column D for the last row instead of A since those are the values you are wanting to transpose:
Sub test()
Dim i As Long, lastrow As Long
lastrow = ActiveSheet.Cells(Worksheets(1).Rows.Count, "D").End(xlUp).Row
For i = 2 To lastrow
Cells(i, 1).Select
If i < 6 Then
Cells(i, 6) = Cells(i, 4).Value
Else
Cells(i, 7) = Cells(i, 4).Value
End If
Next i
End Sub
First Try using below function to get Last Row, this is very handy.
Function LastRow(sh As Worksheet) As Integer
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function
One more for Last column, just in case for your Future reference.
Function LastColumn(sh As Worksheet) As Integer
On Error Resume Next
LastColumn = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlValues, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
On Error GoTo 0
End Function
Now the Actual working procedure
Sub test()
Dim i as Long, InptClm as integer 'good to define the variable otherwise they will be considered as variant which is at higher memory rank.
Dim LastRow As Integer: LastRow = LastRow(activeworkbook.Sheets("Type sheet name here")
With activeworkbook.Sheets("Type Sheet Name here")
For i = 2 To lastrow
' you don't have to select here as selection slows the performance of codes.
If .Cells(i, 1).Value <> "" Then
' Below code will make the column selection dynamic
inptclm = .rows(1).find(What:=.cells(i,1)&" (Fruits)",After:=Cells(1,1),Lookat:=xlwhole).column()
End If
.Cells(i, inptclm) = Cells(i, 4).Value
Next I
end with
End sub
-- Code not tested, hope it will be able to assist you.
You could use SpecialCells to isolate each blank cells group in column A
Option Explicit
Public Sub test()
Dim iArea As Long
For Each area in Range("D2", Cells(Rows.Count, "D").End(xlUp)).Offset(,-3).SpecialCells(xlCellTypeBlanks).Areas
With area.Offset(-1).Resize(.Rows.Count + 1)
Range("F1").Offset(,iArea).Value = .Cells(1,1).Value
Range("F2").Offset(,iArea).Resize(.Rows.Count).Value = .Value
End With
iArea = iArea + 1
Next
End Sub
I am having real difficulty finding anything that has my query. I can find the different pieces of what I need but cannot put it together.
What I need to do is look through a set range and if value is between 0.001 and 0.26 then
copy cell and paste in next empty cell in column ("DA"), also copy cell from the same row that the value was found but copy from column ("C") and paste in next to column ("DB").
I know I have to loop through with an If statement, and will have to offset cell when it finds match to criteria. but I cannot put it together.
I have tried the following pieces of code.
Sub COPYcell()
Dim Last As Long
Dim i As Long, unionRng As Range
Last = 61
Dim lastrow As Long
lastrow = Sheets("Sheet1").Range("DA100").End(xlUp).Row
For i = 5 To Last
If (.Cells(i, "J").Value) >= 0.01 And (.Cells(i, "J").Value) <= 0.26 Then
'Cells(i, "DA").Value = Cells(i, "J").Value
Range(i, "J").Copy = Range("DA" & lastrow)
Cells(i, "J").Offset(, -8) = Range("DB" & lastrow)
Range("DC" & lastrow) = "July"
End If
Next i
End Sub
Try the following:
Option Explicit
Public Sub COPYcell()
Dim last As Long, sht1 As Worksheet
Dim i As Long, unionRng As Range, lastrow As Long, nextRow
Application.ScreenUpdating = False
Set sht1 = Worksheets("Sheet1")
last = 61
With sht1
lastrow = .Cells(.Rows.Count, "DA").End(xlUp).Row
nextRow = IIf(lastrow = 1, 1, lastrow + 1)
For i = 5 To last
If .Cells(i, "J").Value >= 0.01 And .Cells(i, "J").Value <= 0.26 Then '1%=26%
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, .Cells(i, "J"))
Else
Set unionRng = .Cells(i, "J")
End If
End If
Next i
If Not unionRng Is Nothing Then
unionRng.Copy .Range("DA" & nextRow)
unionRng.Offset(0, -7).Copy .Range("DB" & nextRow)
End If
End With
Application.ScreenUpdating = False
End Sub
Your current code was giving me errors about range objects. I kept it simple and assigned cell values to cell values. Also, I am not sure if you meant .01 or .001. You may fiddle with that. The issue I saw was that as you find more matches, you want lastrow to go up so you are writing in what is now the last row, not what once was. You also had some unused variables pasted in, so I simplified. Here is the result.
Sub COPYCell()
Dim Last As Long
Dim i As Long
Last = 61
Dim lastrow As Long
lastrow = Sheets("Sheet1").Range("DA100").End(xlUp).Row + 1
For i = 5 To Last
If (Cells(i, "J").Value <= 0.26) And (Cells(i, "J").Value >= 0.001) Then
Cells(lastrow, "DA").Value = Cells(i, "J").Value
Cells(lastrow, "DB").Value = Cells(i, "C").Value
Cells(lastrow, "DC").Value = "July"
lastrow = lastrow + 1
End If
Next i
End Sub
EDIT Added +1 on lastRow per comment. I had tested where I had none yet.
You need to loop your range and inside loop check if you cell is not empty copy the cell value and in else paste in next empty cell.
Sample code:
Sub Func ()
Dim rng As Range, cell As Range
Set rng = Range("A1:A3")
For Each cell In rng
If (IsEmpty(cell.value))
Cell.paste()
Else
cell.copy()
End if
Next cell
End sub
The code is not tested because I typed it on a phone.
I'm trying to make a macro that will scroll through a spreadsheet an entire row at a time and merge all cells in the active row if they have data. It should do this until the last row.
The code currently sees all rows as empty and therefor skips them, I need an if condition or do until statement that will help detect and skip empty rows, detect rows with data and merge their cells and stop entirely when it reaches the last row.
My current code:
Sub merge()
Dim LastRow As Long, i As Long
Sheets("Body").Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows("1:1").Select
For i = 1 To LastRow
If Range("A" & i).Value = "*" Then
Selection.merge = True
Selection.Offset(1).Select
Else
Selection.Offset(1).Select
End If
Next i
End Sub
I have also tried:
sub merge2()
Dim LastRow As Long, i As Long
Sheets("Body").Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows("1:1").Select
Do Until ActiveCell.EntireRow > LastRow
'this line below was a concept
If ActiveCell.EntireRow & ActiveCell.Column.Value = "*" Then
Selection.merge = True
Selection.Offset(1).Select
Else
Selection.Offset(1).Select
End If
Loop
End Sub
This is untested but should do what you want.
Option Explicit
Sub merge()
Dim ws As Worksheet
Dim LastRow As Integer, i As Integer
Set ws = ThisWorkbook.Sheets("Body")
ws.Activate
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRow
If Not IsEmpty(Range("A" & i)) And ws.Cells(i, Columns.Count).End(xlToLeft).Column > 1 Then
ws.Rows(i & ":" & i).merge
End If
Next i
End Sub
This If will test for a) whether the cell in column A is empty and b) whether there are any other cells in that row. if statement a evaluates to false AND statement b is greater than 1 it will execute the If statement
#Tom I've taken your code and added in an error handler that makes it work without fault, thank you very much for your patience, you've been a fantastic help.
Sub merge2()
Dim ws As Worksheet
Dim LastRow As Integer, i As Integer
Set ws = ThisWorkbook.Sheets("Body")
ws.Activate
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRow
If Not IsEmpty(Range("A" & i)) And ws.Cells(i, Columns.Count).End(xlToLeft).Column >= 1 Then
On Error Resume Next
ws.Rows(i & ":" & i).merge = True
End If
Next i
End Sub
I have found the code
Sub Test()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows,SearchDirection:=xlPrevious).Row
Dim lColumn As Long
Dim x As Long
Dim rng As Range
For Each rng In Range("A1:A" & LastRow)
lColumn = Cells(rng.Row, Columns.Count).End(xlToLeft).Column
For x = 1 To lColumn - 2
Range(Cells(rng.Row, "A"), Cells(rng.Row, "B")).Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = rng.Offset(0, x + 1)
Next x
Next rng
Application.ScreenUpdating = True
End Sub
I am trying to modify it to suit my needs but it isn't quite doing what I need it to do.
Basically, my table is like this:
A B C D
FILENAME ID FIELD1 FIELD2
1 2 3 4
and I want it to look like this:
A FILENAME 1
B ID 2
C FIELD1 3
D FIELD2 4
however, sometimes there may be more columns or rows associated with a given part of the range that is related to a set of data. right now the columns that
I don't know nearly enough about excel and vba to modify this code to do that, but it would be nice if I could.
below are a couple of links that explain closely how I want the final table to look.
http://pastebin.com/1i5MqTL7
http://imgur.com/a/PKAcy
The ID's are not unique product pointers, but that's the REAL world. Different considerations and assumptions about the consistency of your input data, but try this:
Private Sub TransposeBits()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
'start will be the starting row of each set
Dim start As Long
start = 2
'finish will be the last row of each set
Dim finish As Long
finish = start
Dim lastRow As Long
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'printRow will keep track of where to paste-transpose each set
Dim printRow As Long
printRow = lastRow + 2
'lastCol will measure the column count of each set
Dim lastCol As Long
'Just dealing with a single entry here - delete as necessary
If lastRow < 3 Then
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
'in the trivial case, we can exit the sub after dealing with the one-line transpose
Exit Sub
End If
'more general case
For i = 3 To lastRow
If Not Range("A" & i).Value = Range("A" & i - 1).Value Then
'the value is different than above, so set the finish to the above row
finish = i - 1
lastCol = Cells(start, 1).End(xlToRight).Column
'copy the range from start row to finish row and paste-transpose
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
'after finding the end of a set, reset the start and printRow variable
start = i
printRow = printRow + lastCol
End If
Next i
'here we deal with the last set after running through the loop
finish = lastRow
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
End Sub
You can use the Paste Special that #Jeeped uses - just write it in code:
Sub TransposeData()
Dim rLastCell As Range
With ThisWorkbook.Worksheets("Sheet1")
'NB: If the sheet is empty this will throw an error.
Set rLastCell = .Cells.Find("*", SearchDirection:=xlPrevious)
'Copy everything from A1 to the last cell.
.Range(.Cells(1, 1), rLastCell).Copy
'Paste/Transpose in column A, one row below last row containing data.
.Cells(rLastCell.Row + 1, 1).PasteSpecial Transpose:=True
End With
End Sub
I've got a sheet set up to get the contents of the last row. I want to check the values on that last row from J to W. I want to check if all the values are "YES" and if so return an OK into a variable. Here is what I have so far, it should be clear from the below what I am trying to do:
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
sName = ActiveSheet.Name
For Each c In Worksheets(sName).Range(Cells(J, lastRow), Cells(W, lastRow))
If c.Value = "YES" Then
vData = "OK"
Else
vData = "Error."
End If
Next c
Thanks.
Cells(x,y) takes two integers as arguments, and it's row, column not column, row!
Try
For Each c In Sheets(sName).Range(Cells(lastRow, 10), Cells(lastRow, 23))
Dim lRow As Long
Dim lCol As Long
Dim ws As Excel.Worksheet
Set ws = Application.ActiveSheet
lRow = ws.UsedRange.Rows.count
lCol = 10
Do While lCol <= 21
If ws.Cells(lRow, lCol).Value <> "YES" Then
vData = "Error."
Exit Sub
End If
lCol = lCol + 1
Loop
Try this one:
Public Sub checking()
Dim lastRow As Long
'Here, I take row count by using column "J"
'You can modify it if you need
lastRow = Sheets("sheetname").Range("J" & Rows.Count).End(xlUp).row
For Each cell In Sheets("sheetname").Range("J" & lastRow & ":W" & lastRow)
If cell.Value = "YES" Then
vData = "OK"
Else
vData = "Error."
Exit For
End If
Next cell
'Show result
MsgBox vData
End Sub