I'm having trouble with an assignment.
I'm having this sheet with 18287 students. One in each row. They have individual person ID's, they have different campus', they've been enrolled for their education at different times etc. etc.
I'm building a loop-code, that finds the students that are delayed and have been rolled back. If they are delayed, the H column has to be below 133. Equally i'm looking for students currently studying a bachelor degree. Which means that column L must be "Bachelor". My loop looks like this at the time:
for i = 2 to 18288
If worksheets(1).range(i,5)<133 and worksheets(1).range(i,11)="Bachelor" then
worksheets(1).row(i).copy
I'm trying to copy the row to the first empty row in worksheet (Delayed Students). I've tried many different approaches. Some of them don't copy anything, other attempts has resulted in excel shutting down... I've searched Google, and what I've concluded is that the .select, .copy, .paste procedures are very demanding, and could cause a crash.
So i'm looking for a code, where I don't necessarily have to copy the rows. Any help with that, I'm running out of possible solutions myself..?
Did you ever think about filtering column H < 133 and L for "Bachelor"? I think filters are much easier and should even be faster.
With Worksheets(1).UsedRange
.AutoFilter Field:=8, Criteria1:="<133", Operator:=xlAnd
.AutoFilter Field:=12, Criteria1:="=Bachelor", Operator:=xlAnd
.SpecialCells(xlCellTypeVisible).Copy
End With
Worksheets("SheetToPasteIn").Range("A1").PasteSpecial
The most consuming time for the code is to access the Worksheet, like the Copy command. You can minimize by using a CopyRng object to merge all the Rows that pass your criteria, using the Union function.
At the end you just Copy the entire range at once.
Note: column "H" using the Range in your loop should be Range("H" & i), and not range(i,5). The same for the other case.
Try the modified code below:
Dim i As Long
Dim CopyRng As Range
With Worksheets(1)
For i = 2 To 18288
If .Range("H" & i).Value < 133 And .Range("K" & i).Value2 = "Bachelor" Then
If Not CopyRng Is Nothing Then
Set CopyRng = Application.Union(CopyRng, .Rows(i))
Else
Set CopyRng = .Rows(i)
End If
End If
Next i
End With
' check at least 1 rows in the Range
If Not CopyRng Is Nothing Then CopyRng.Copy
Related
I'm a beginner so bear with me
The code I'm using now is this, given to me by user "Xabier", slightly edited by me. This copies the rows with a certain document# into a separate sheet, thus giving me a list:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("inbd")
Dim wsDestination As Worksheet: Set wsDestination = Sheets("test")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("A1:N" & LastRow).AutoFilter Field:=1, Criteria1:=Worksheets("test").Cells(1, 26).Value
ws.Range("A2:N2" & LastRow).SpecialCells(xlCellTypeVisible).Copy
DestinationRow = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
wsDestination.Range("A" & DestinationRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
ws.Range("A1:N" & LastRow).AutoFilter Field:=1
End Sub
Now what I want to do is create something like a header for the document containing data regarding the origin of the imports.
This data is the "Import#", "Invoice#", "Supplier" and "Invoice date". Basically for every unique Invoice# I need to create a unique entry even if the supplier or the import# is the same.
And I can't copy the entire row, I just need to copy certain cells in each row.
After I actually figure out how all this works, this is how the document is going to look.
this is actually a pretty involved solution that StackOverflow is not meant for. Instead, i'll give you an idea of how you could implement this yourself.
loop through filtered data
if not first loop, check if the previous new sheet's invoice number matches this one
check that new sheet is not too full to add invoice
copy this row's invoice information to new sheet
looping through filtered data
copying data from cell to cell
I'm trying to make a code that checks for numbers in a master sheet called All in column D (ex. 780101) and if it meets the criteria, it copies the whole row and inserts (not paste) it to another sheet with the name of the criteria (ex. 780101), starting on row 6.
The code I have doesn't work like I want it to. It doesn't copy all the rows that meet the criteria and sometimes it inserts blank rows.
Sub Insert()
For Each Cell In Sheets("All").Range("D:D")
If Cell.Value = "780101" Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow + 1).Select
Selection.Copy
Sheets("780101").Select
Rows("6:6").Select
Selection.Insert Shift:=xlDown
End If
Next
End Sub
I'm just starting to learn VBA, so if it could be possible the names of the sheets would be the criteria of the cell values (the code is made for only one sheet - 780101, but there are 20 of sheets with different names).
It's tough to make recommendations without seeing sample data and what could potentially be causing the problems you are having but you can run this rehash of your existing code.
Sub Insert()
Dim dc As Range
With Sheets("All")
For Each dc In Intersect(.Range("D:D"), .UsedRange)
If dc.Value2 = 780101 Then
dc.Resize(2, 1).EntireRow.Copy
Sheets("780101").Rows(6).Insert Shift:=xlDown
End If
Next
End With
End Sub
The nature of running that from top to bottom means that the results will be reversed. You may wish to consider running the main loop from bottom to top to maintain the order.
Really hope someone out there can help me. So i have the following code. The independent codes work fine by themself, but when executing the script, it only loops through the first condition. What i want it to do is to loop through all the code, each time. I think it's a small thing I am missing, but i can't seem to find a solution.
Sub Copypre()
Dim i As Integer
Dim n As Integer
For i = 2 To 10
'Checks the number of entries in the "Pre" table, to make sure that there are no spaces between the lines
On Error Resume Next
n = Worksheets("Pre").Range("A2:A6000").Cells.SpecialCells(xlCellTypeConstants).Count
If n = Null Then
n = i
'Goes through the different sheets to find all "pre" values and paste them in the "Pre" sheet
If ThisWorkbook.Sheets("273").Range("A" & i).Value = "Pre" Then
Range(Cells(i, 1), Cells(i, 3)).Select
Selection.Copy
Sheets("Pre").Select
Range("A" & n).Select
ActiveSheet.Paste
Sheets("2736").Select
End If
End If
Next i
End Sub
There are a couple of issues with your code, but the main issue may be that If n = Null will never be true since an integer cannot be Null. You could change this to If n = 0.
A couple of things to consider:
Error handling: Always go back to normal error handling with On Error GoTo 0 as soon as possible. This way you would have known (assuming that there is no sheet "2736" in your workbook) that your code is trying to select a sheet that does not exist.
Range argument: Be carefull when not specifying the sheet when using the Range (and Cells) argument. When you switch back and fourth between different sheets that you select, there is a change that you may loose track of what sheet the Range is returning data from. Consider declaring each worksheet and then copy your ranges like:
Dim w273 As Worksheet
Set w273 = ThisWorkbook.Sheets("273")
w273.Range(w273.Cells(i, 1), w273.Cells(i, 3)).Copy
Loops can quickly consume time with long columns of data and I suspect that your code was heavily redacted. Try this alternate method of block copying across to the destination worksheet.
Sub Copypre()
With Sheets("273").Cells(1, 1).CurrentRegion
.AutoFilter
.Columns(1).AutoFilter field:=1, Criteria1:="=Pre"
If CBool(Application.Subtotal(103, .Offset(1, 0))) Then
.Offset(1, 0).Resize(, 3).Copy _
Destination:=Sheets("Pre").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
.AutoFilter
End With
End Sub
All that can get accomplished without a single variable declaration.
Addendum:
As to your original question, the whole if "pre"/copy/paste section is nested within the if n = Null so it can only be reached if n = Null is true. If there are no .SpecialCells(xlCellTypeConstants)to count, n will be assigned its default value (e.g. 0). Zero is not equal to Null so that condition is never met. To check your code, add the following line.
On Error Resume Next
n = Worksheets("Pre").Range("A2:A6000").Cells.SpecialCells(xlCellTypeConstants).Count
Debug.Print "n is " & n
After running it, open the Immediate window with Ctrl+G. If there are no non-formula values in Pre!A2:A6000 you should see n is 0.
Thanks allot for all the advices. The null trick worked! I am totally new to VBA so it's nice to get some tips and tricks from experts. I will try to make the code more simple as Jeeped mentioned, as this is not very elegant. In regards to the sheets, i can totally understand the confusion, i have fixed that also. It works now and looks like this:
Sub Copypre()
Dim i As Integer
Dim n As Integer
For i = 2 To 5000
' Checks the number of entries in the "Pre" table, to make sure that there are no spaces between the lines
On Error Resume Next
n = Worksheets("Pre").Range("A2:A6000").Cells.SpecialCells(xlCellTypeConstants).Count
' Goes through the different sheets to find all pre values and paste them in the "Pre" sheet
If ThisWorkbook.Sheets("2736").Range("A" & i).Value = "Pre" Then
Sheets("2736").Select
Sheets("2736").Range(Cells(i, 1), Cells(i, 3)).Select
Selection.Copy
Sheets("Pre").Select
Range("A" & (n + 2)).Select
ActiveSheet.Paste
Sheets("2736").Select
Sheets("2736").Select
Range(Cells(i, 5), Cells(i, 6)).Select
Selection.Copy
Sheets("Pre").Select
Range("E" & (n + 2)).Select
ActiveSheet.Paste
Sheets("2736").Select
End If
Next i
End Sub
I guess this is pretty straight forward, but for some reason it just does not seem to work for me :(
I have the below code which auto-filters the data based on the criteria that I have specified:
Dim lastrow As Long
lastrow = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
With Sheet2
.AutoFilterMode = False
With .Range("A1:AF" & lastrow)
.AutoFilter
.AutoFilter Field:=7, Criteria1:="Yes", Operator:=xlFilterValues
End With
What I am now looking to do is delete all the Unfiltered (Hidden) rows that do not fit the criteria.
I tried so far:
Sub RemoveHiddenRows
Dim oRow As Object
For Each oRow In Sheets("Sheet2").Rows
If oRow.Hidden Then oRow.Delete
Next
End Sub
But the problem with this code is that it would only remove every other row of consecutive hidden rows because the each increments the row considered even when a row has been deleted and all lower rows have moved up one.
Also I would prefer something without a loop if it's possible, kind of like the opposite of .SpecialCells(xlCellTypeVisible).EntireRow.Delete
All help will be highly appreciated.
So I was kind of looking to get rid of Unfiltered Data rather than trying to reverse all the criteria and delete the visible cells
I would use this one:
Sub RemoveHiddenRows()
Dim oRow As Range, rng As Range
Dim myRows As Range
With Sheets("Sheet3")
Set myRows = Intersect(.Range("A:A").EntireRow, .UsedRange)
If myRows Is Nothing Then Exit Sub
End With
For Each oRow In myRows.Columns(1).Cells
If oRow.EntireRow.Hidden Then
If rng Is Nothing Then
Set rng = oRow
Else
Set rng = Union(rng, oRow)
End If
End If
Next
If Not rng Is Nothing Then rng.EntireRow.Delete
End Sub
I used Dmitry Pavliv's solution for my filtered table and it worked (thanks!) but would intermittently give error: "delete method of range class failed" error.
Error seemed to occur when only one hidden row was to be deleted. It may or may not be of significance that the lone hidden row was right under the table header.
Stepping through the code, rng pointed to correct cell, and showed just the single cell. It was probably an issue with using a Table instead of named range, though other hidden rows deleted fine in same table format.
Macro has been working fine after I modified the last portion of the code
from this:
If Not rng Is Nothing Then rng.EntireRow.Delete
To this:
If rng.Rows.Count = 1 Then
ws.Rows(rng.Row & ":" & rng.Row).Delete
ElseIf rng Is Nothing Then
rng.EntireRow.Delete
End If
For some reason, deleting that single row in this format works. I'm not quite sure why. The rng object is pointing to the correct cell and I'm using it to get the row number, so not sure why it's not working in rng.entirerow.delete statement. Oh well. Sharing as came across many posts with same error unresolved.
I’ve been working on this VBA code for a while and since I’m a complete noob I feel like I haven’t gotten anywhere. I’ve been researching a ton, but can’t seem to combine answers to help with my scenario.
Essentially what I’m trying to do is grab data, line by line, from one worksheet and extrapolate it to another worksheet. I believe this will involve loops and I’m so new with VBA I don’t know how to do it.
Here’s the logic I’m attempting:
For each row on worksheet 1, I would like to perform 3 different copy and paste activities to worksheet 2 and then it will loop down to the next row on sheet1 and do the 3 activities and so on. This will continue downwards until column A is blank in sheet1. Sheet1 data starts at A3 and sheets2 paste area starts at A2.
The first activity is to copy cells F3,D3,A3, and H3 (in that order so F3 will be A2, D3 will be B2 etc) from sheet 1 to sheet 2 to A2,B2,C2, etc. A destination functions can’t be used because I need just the values and no other formats—one of the many issues I’ve ran in to.
The next activity is to copy cells F3,D3,A3 and I3 from sheet 1 to sheet2 pasted below the previous copy and paste—again no formats just values. Also to note, some of these may be blank (except A column) but I still need that row there with at least column A data—this goes to say with all these activities.
The third activity is to copy and paste sheet1’s F3,D3, and A3 a certain number of times referencing K3’s number—and each copy and paste will be in the next available blank cell. So if the number in K3 it will look like it created 3 rows in sheet2—totaling 5 rows on sheet2 since activity1 and 2 each create their own row.
After these three activities are completed for row 3 on sheet 1, it will then move to row 4 and do the previous three activities and paste to sheet2. And again it will be pasting no formats and in the next blank row on sheet 2. Also again, this loop will stop once the cell in Column A is blank.
Below is my incomplete code. I don’t even think it will help one bit and it would probably be better not to even look at it. I’ve just started to get frustrated since I can’t even do a simple copy and paste, yet alone loops within loops. I also haven’t even started on my third activity. I greatly appreciate it!
Sub copyTest3()
Dim proj As Range, release As Range, pm As Range, lead As Range, coord As Range
Dim leadCopy As Range, coordCopy As Range
Dim i As Range
Set proj = Range("A3", Range("A3").End(xlDown))
Set release = Range("D3", Range("D3").End(xlDown))
Set pm = Range("F3", Range("F3").End(xlDown))
Set lead = Range("H3", Range("H3").End(xlDown))
Set coord = Range("I3", Range("I3").End(xlDown))
Set leadCopy = Union(pm, release, proj, lead)
Set coordCopy = Union(pm, release, proj, coord)
For i = 1 To Range(ActiveSheet.Range("A3"), ActiveSheet.Range("A3").End(xlDown))
leadCopy.Copy
Sheets("Sheet2").Activate
Range("A2").Select
ActiveSheet.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Sheets("Sheet1").Activate
coordCopy.Copy
Sheets("Sheet2").Activate
Range("A2").Select
ActiveSheet.PasteSpecial xlPasteValues
Next i
End Sub
There are many ways to do this, and some are more efficient than others. My solution may not be the most efficient, but hopefully it will be easy for you to understand so that you can learn.
It's very difficult to understand what you're attempting to do in activity three, so I wasn't able to provide a solution to that step. Use my code as a template for step three and if you run into issues, feel free to leave a comment.
Notice that I don't use .Activate, .Select, or .Copy in this code. .Activate and .Select are huge efficiency killers, and they make it easier for your code to "break," so avoid using them when possible. .Copy isn't necessary when working with values or formulas and will also slow your code down.
Untested
Sub testLoopPaste()
Dim i As Long
Dim ii As Long
Dim i3 as Long
Dim LastRow As Long
Dim wb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("Sheet1")
Set sht2 = wb.Sheets("Sheet2")
'Find the last row (in column A) with data.
LastRow = sht1.Range("A:A").Find("*", searchdirection:=xlPrevious).Row
ii = 2
'This is the beginning of the loop
For i = 3 To LastRow
'First activity
sht2.Range("A" & ii) = sht1.Range("F" & i).Value
sht2.Range("B" & ii) = sht1.Range("D" & i).Value
sht2.Range("C" & ii) = sht1.Range("A" & i).Value
sht2.Range("D" & ii) = sht1.Range("H" & i).Value
ii = ii + 1
'Second activity
sht2.Range("A" & ii) = sht1.Range("F" & i).Value
sht2.Range("B" & ii) = sht1.Range("D" & i).Value
sht2.Range("C" & ii) = sht1.Range("A" & i).Value
sht2.Range("D" & ii) = sht1.Range("I" & i).Value
ii = ii + 1
'Third activity
For i3 = 1 To sht1.Range("K" & I)
sht2.Range("A" & ii) = sht1.Range("F" & i).Value
sht2.Range("B" & ii) = sht1.Range("D" & i).Value
sht2.Range("C" & ii) = sht1.Range("A" & i).Value
ii = ii + 1
Next i3
Next i
End Sub
The way I usually approach copying data between sheets in Excel is to create source range and destination range objects, each range referring to just one row. When I want to move on to the next row, I use Offset to return a range offset to the next row.
Since the ranges only refer to one row, you can index them with an integer to get the cells in the row. E.g. if cursor refers to columns A through D in row 3, cursor(3) will give you the cell C3.
Dim src_cursor As Range
Dim dest_cursor As Range
Set src_cursor = ActiveSheet.Range("A3:I3")
Set dest_cursor = Sheets("Sheet2").Range("A2:D2")
'' Loop until column A is empty in source data
Do Until IsEmpty(src_cursor(1))
dest_cursor(1) = src_cursor(6) '' copy F -> A
dest_cursor(2) = src_cursor(4) '' copy D -> B
'' and so on
'' move cursors to next row
Set src_cursor = src_cursor.Offset(1, 0)
Set dest_cursor = dest_cursor.Offset(1, 0)
Loop
Also, this might be getting a little off topic, but it's a better practice to use an Enum to name the column numbers instead of hardcoding them like I did here.