VBA code in excel operates inconsistently with very simple code - excel

I wrote some pretty simple VBA (excel macros) code to manage my audio licencing excel experience. The code is supposed to look through the excel sheet in column 3, look for any that have "AMC" in their column, and then copy and paste the row to sheet 2 and continue searching through entire excel document. This code is very simple and worked once right before it stopped working right. It only takes the very last AMC value and puts that on sheet 2 but not the other 5 rows that have AMC in their column 3 value.
Please help! I would appreciate it very much :)
-Jeremy
VBA Code:
Sub CommandButton1_Click()
a = Worksheets("Sheet1").UsedRange.Rows.Count
b = 0
For i = 2 To a
If Worksheets("Sheet1").Cells(i, 3).Value = "AMC" Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets("Sheet2").Activate
' b = ActiveSheet.UsedRange.Rows.Count
Worksheets("Sheet2").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Sheet1").Activate
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select
End Sub

This should solve your problem :
If Worksheets("Sheet1").Cells(i, 3).Value = "AMC" Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets("Sheet2").Activate
Worksheets("Sheet2").Cells(b + 1, 1).Select
b = b + 1
ActiveSheet.Paste
Worksheets("Sheet1").Activate
End If

You could use Instr and Union.
Union is very efficient as you store all the qualifying ranges in memory and then write out only once to the sheet. Much less expensive operation than continually writing out to the sheet.
Instr allows you to use vbBinaryCompare which means you are doing a case sensitive match i.e. only AC not ac will be matched on.
The code belows avoids .Activate, which is again an expensive operation that isn't required.
UsedRange means you may be looping many more rows than required. You only want to loop to the last populated row in column C of sheet 1, as that is the column you are testing. Hence, I use .Cells(.Rows.Count, C").End(xlUp).Row to find that last row.
Use Option Explicit - research why! It will make your VBA life soooooo much better.
Code:
Option Explicit
Sub CommandButton1_Click()
Dim lastRow As Long, sSht As Worksheet, tSht As Worksheet, loopRange As Range
Set sSht = ThisWorkbook.Worksheets("Sheet1")
Set tSht = ThisWorkbook.Worksheets("Sheet2")
With sSht
Set loopRange = .Range("C2:C" & .Cells(.Rows.Count, C").End(xlUp).Row)
End With
Dim rng As Range, unionRng As Range
For Each rng In loopRange
If InStr(1, rng.Value, "AC", vbBinaryCompare) > 0 Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, rng)
Else
Set unionRng = rng
End If
End If
Next rng
If Not unionRng Is Nothing Then unionRng.EntireRow.Copy tSht.Cells(1, 1)
End Sub

Related

How can I repeat code through entire data?

I have written a few lines of code that work like I want them too but I don't know how to repeat it through all rows of my data.
This probably seems like a rather simple thing but since I started VBA just a few days ago I struggle with this line of code
If I continue with ActiveCell.Offset(-1,-4) after my code it's a bug and I don't know how to repeat the code through all rows.
Sub SelectRowsWithNoBlanks()
Range("A2").Select
If ActiveCell.Offset(0, 0).Value <> "" And ActiveCell.Offset(0, 1) <> "" And ActiveCell(0, 1) <> "" And ActiveCell(0, 1) <> "" Then
Range(ActiveCell, Cells(ActiveCell.Row, ActiveCell.Column + 4)).Select
End If
End Sub
#SiddharthRout As I don't have Access to the data yet I can't tell. But I thought extending the code for more columns later on wouldn't be a problem. So in the code I have written now I was checking for the columns A-D but I thought I could easily add the "checking" for more columns if needed – Anna von Blohn 43 secs ago
In that case, here is a sample code.
Logic
As #Pᴇʜ mentioned avoid the use of .Select. Work with the objects.
Find the last row and loop through the rows. To find the last you you may want to see This
One way (which I am using) is to count the number of cells which are filled using Application.WorksheetFunction.CountA. So if it is columns A to D then there should be 4 cells to be filled to consider the "row" as filled. Similarly for Cols A to E, there should be 5 cells to be filled to consider the "row" as filled as so on.
Code
I have commented the code. So if you have a problem understanding it, let me know.
Option Explicit
Sub SelectRowsWithNoBlanks()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim myRange As Range, rng As Range
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find the last row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the rows
For i = 2 To lRow
'~~> Change this as applicable
Set rng = .Range("A" & i & ":D" & i)
'~~> Check if the range is completely filled
If Application.WorksheetFunction.CountA(rng) = rng.Columns.Count Then
'~~> Store the range in a range object
If myRange Is Nothing Then
Set myRange = rng
Else
Set myRange = Union(myRange, rng)
End If
End If
Next i
End With
'If Not myRange Is Nothing Then Debug.Print myRange.Address
'~~> Check if any filled rows were found
If Not myRange Is Nothing Then
With myRange
'
'~~> Do what you want with the range
'
End With
Else
MsgBox "No filled rows were found"
End If
End Sub

Excel VBA: Delete rows if value not equal to a value?

So I've been searching hard to find why my code hasn't been working, but every time I try, I get a result where nothing is changed. Can someone please tell me what I'm missing? Sorry, I'm a total novice but I'm trying.
Dim Cell As Range
With Sheets(1)
' loop column D until last cell with value (not entire column)
For Each Cell In .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
If Cell.Value <> 110 Then
Rows(Cell.Row).EntireRow.Delete
End If
Next Cell
End With
Instead of looping, make use of excels inbuilt functions, its cleaner and more concise.
With Sheets(1).UsedRange
.AutoFilter Field:=4, Criteria1:="<>110"
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
if you insist on looping then use the following code:
With Sheets(1).UsedRange
For lrow = .Rows.Count To 2 Step -1
If .Cells(lrow, 4).Value <> 110 Then .Rows(lrow).Delete
Next lrow
End With
Untested, but maybe something like:
Option explicit
Sub DeleteRows()
With thisworkbook.worksheets(1)
' loop column D until last cell with value (not entire column)
Dim lastRow as long
lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
Dim rowIndex as long
For rowIndex = lastRow to 2 step -1
If .cells(rowIndex, "D").value2 <> 110 then
.cells(rowIndex, "D").entirerow.delete
End if
Next rowIndex
End With
End sub
If you have a lot of rows, you could use union to build a range consisting of all rows to be deleted, then delete them in one go.

Performance Improvement on Column Header Search and Worksheet Loop VBA

I have a row of dynamic column headers in the "Summary" tab and 111 worksheets appended at the end of the workbook, although this number is subject to change. I search for each column header in each appended worksheet and copy the cell immediately beneath any match to its corresponding column and row, a new row for each appended worksheet, in the "Summary" tab. The output meets my expectations. The time necessary to loop through every appended worksheet does not. Please let me know if there are obvious ways to optimize the code or more efficiently achieve my desired results. Thanks in advance.
Sub riasummary()
Dim riawksht As Worksheet
Dim consolwksht As Worksheet
Dim c As Integer
Dim r As Long
Dim sheader As Range
Dim sheaders As Range
Dim rheader As Range
Dim rheaders As Range
c = Sheets("Summary").Cells(1, Columns.Count).End(xlToLeft).Column
Set sheaders = Sheets("Summary").Range(Cells(1, 1), Cells(1, c))
For Each riawksht In ActiveWorkbook.Worksheets
If riawksht.Name <> "Summary" Then
Set rheaders = riawksht.Range("a5:xfd12")
For Each rheader In rheaders
For Each sheader In sheaders
r = Sheets("Summary").Cells(Rows.Count, "a").End(xlUp).Row
If rheader.Value = sheader.Value Then
rheader.Offset(1, 0).Copy
sheader.Offset(r, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
'sheader.Offset(1, 0).Value = rheader.Offset(1, 0).Value
End If
Next
Next
End If
Next
End Sub
As a tangent, I also occasionally return an "Application-defined or object-defined error" at the following line of code that I cannot seem to decipher, and any insight here would be much appreciated as well.
Set sheaders = Sheets("Summary").Range(Cells(1, 1), Cells(1, c))
Set sheaders = Sheets("Summary").Range(Cells(1, 1), Cells(1, c))
Should be:
With Sheets("Summary")
Set sheaders = Sheets("Summary").Range(.Cells(1, 1), .Cells(1, c))
End With
You should always avoid unqualified Cells or Range calls, since they will default (in a regular module) to the active sheet.

Excel expression to copy rows but remove blank rows

I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps

How to copy specific cells from each row in another sheet if certain condition is met?

So my problem is this. I have a workbook with lets say 2 sheets. I have automatically created sheet2 from another program and sheet1 where I would like only some of the information from sheet2.
I am now trying to create a macro that would check each row starting from 14 with the value in E% greater than 15. If the condition is met I would like the macro to copy cell value from C% and E% to sheet1 lets say in A5 and B5 and then proceed to next row in sheet2 pasting the valued to A6 B6 and so on.
Sub Test()
Dim rng As Range
Dim lastRow As Long
Dim cell As Variant
With Sheets("Sheet2")
lastRow = .Range("E" & .Rows.Count).End(xlUp).Row
Set rng = .Range("E14:E" & lastRow)
For Each cell In rng
If cell.Value > 15 Then
'And here is where it gets bugged. I know theres something wrong with the .select but I couldnt think of any other way to
'pick only just the 2 cells needed.
Range(cell.Offset(0, -1), cell.Offset(0, 0)).Select
Selection.Copy
'In here there should also be some code to select where to place the copyed
'data but since it already got bugged couldnt really find a solution for
'it..
Sheets("Sheet1").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
End If
Next
End With
End Sub
so I guess i'll put it together:
Sub Test()
Dim rng As Range
Dim lastRow As Long
Dim cell As Variant
dim count as long
count = 0
With Sheets("Sheet2")
lastRow = .Range("E" & .Rows.Count).End(xlUp).Row
Set rng = .Range("E14:E" & lastRow)
For Each cell In rng
If cell.Value > 15 Then
'And here is where it gets bugged. I know theres something wrong with the .select but I couldnt think of any other way to
'pick only just the 2 cells needed.
Range(cell.Offset(0, -1), cell.Offset(0, 0)).Select
Selection.Copy
'maybe use: Range(cell.Offset(0, -1), cell.Offset(0, 0)).copy
'In here there should also be some code to select where to place the copyed
'data but since it already got bugged couldnt really find a solution for
'it..
Sheets("Sheet1").Activate
Range("A5", B5).offset(count, 0).PasteSpecial 'this will make it so that it starts in a5, and moves down a row each time
count = count + 1 'dont forget to increment count
Sheets("Sheet2").Activate
End If
Next
End With
End Sub
and that's kinda a rough thing..
you might include some error handling like: if not cell.value = "" then or also if not isNumeric(cell.value) then and those together would ensure you're only processing non blank cells with numbers.

Resources