So I have a code that conducts a loop on Vlookup and the intention of this is that based on the vlookup, it moves specific cells over to another specific cell but in another sheet. The code runs but it does not move the data over for some reason. I've tried another approach within the If comment and doing a range with a copy destination but I begin to get object not identified errors. Hoping someone can see what I may be missing on why the values are not getting moved over.
Dim i, j, lastG, lastD As Long
Dim sht, ws As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
End With
' find last row
lastG = Sheets("Log").Cells(Rows.Count, "B").End(xlUp).Row
lastD = Sheets("Slide Layout").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Row
Set sht = Sheets("Log")
Set ws = Sheets("Slide Layout")
' loop over values in "Log"
For i = 2 To lastG
currVal = ws.Cells(Rows.Count, "J").End(xlUp)
lookupval = Sheets("Log").Cells(i, "B") ' value to find
If lookupval = currVal Then
sht.Cells(i, "F") = ws.Cells(lastD)
End If
Next i
On Error Resume Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
End With
End Sub
Not sure if i am following entirely...but it looks like you should have this
sht.Cells(i, "F") = currVal
Update, figured it out! I just replaced the
sht.Cells(i, "F") = ws.Cells(lastD)
with
sht.Cells(i, "F").Copy Destination:=ws.Cells(lastD, "B")
I appreciate the help.
Related
I'm just starting with VBA and I'm trying to play around a bit to see what I can do.
I'm trying to write a macro that auto-generates a report from a subsection of data on a main worksheet.
I want to only copy rows where the value in Column D is "China" AND the value in Column H is "HS". Also I'm only looking to copy data from a selection of the rows (A:C,E,F,G,I,Q,R,AF:AH,AN,AP,AQ).
So far I'm doing this by:
Creating a new sheet
Copying the title row
Searching for relevant data and copy/pasting into the new sheet
By following a few answers I found here and other forums, I put together the following. The top half works just fine (generating the sheet and copying the title row) but the main important part doesn't.
Forgive me if this is a Frankenstein job, I'm new here but trying to learn!
Option Explicit
Sub GenerateHSReport()
'Generating the sheet'
Sheets.Add(Count:=1).Name = "HS Report " & Format(Date, "DD-MM-YY")
'Adding the title row'
Sheets("SANBI - all bids").Range("A4:C4,E4,F4,G4,I4,Q4,R4,AF4:AH4,AN4,AP4,AQ4").Copy
Sheets("HS Report " & Format(Date, "DD-MM-YY")).Activate
Range("A1").Select
ActiveSheet.Paste
'Copying the HS data'
Dim srchtrm As String
Dim rng As Range, destRow As Long
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim c As Range
Dim i As Integer
With Application
.ScreenUpdating = False
.DisplayStatusBar = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set shtSrc = Sheets("SANBI - all bids")
Set shtDest = Sheets("HS Report " & Format(Date, "DD-MM-YY"))
Set c = Range("A5:C5,E5,F5,G5,I5,Q5,R5,AF5:AH5,AN5,AP5,AQ5")
destRow = 2
Set rng = Application.Intersect(shtSrc.Range("D:D, H:H"), shtSrc.UsedRange)
For Each c In rng.Cells
If c.Value = "HS" And c.Value = "China" Then
c.Copy shtDest.Cells(destRow, 2)
destRow = destRow + 1
End If
Next
With Application
.ScreenUpdating = True
.DisplayStatusBar = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Application.CutCopyMode = False
End Sub
Update
Thanks commenters, it works! How exciting! FYI i had to add a line per each column I wanted to copy, as per below. Maybe it's a bit messy but it seems to work!
shtDest.Cells(destRow, 1).Value = Row.Columns("a").Value
shtDest.Cells(destRow, 2).Value = Row.Columns("b").Value
shtDest.Cells(destRow, 3).Value = Row.Columns("c").Value
'...etc'
I'm on my phone so, I can'tvtest right now, but it should direct you in the right direction
Set rng = shtSrc.UsedRange
Dim row as range
For Each row In rng.rows
If row.columns("h").value = "HS" And row.columns("d").value = "China" Then
shtDest.Cells(destRow, 2).value = Row.columns("b").value
destRow = destRow + 1
End If
Next
Domething like that, you get the idea, again, it's not tested
I am running the following code on a spreadsheet:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
End If
i = i + 1
Loop
There are plenty of entries with not "String" but they do not get deleted.
When I copy this piece of code to a separate sheet, I even get the error "Excel cannot complete this task with available resources. Choose less data or close other applications."
What am I doing wrong that is making this loop not work?
Note: I can't use autofilter because I need to delete rows based on not meeting a condition.
This is the worst way to delete a row. Reasons
You are deleting the rows in a Loop
Your Cells Object are not qualified
Try this.
Co-incidentally I answered a similar question in the MSDN forum as well. Please See THIS
Try this way (UNTESTED)
In the below code I have hardcoded the last row to 100000 unlike as done in the above link.
Sub Sample()
Dim ws As Worksheet
Dim i As Long
Dim delRange As Range
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
For i = 1 To 100000
If .Cells(i, 4).Value <> "String" Then
If delRange Is Nothing Then
Set delRange = .Rows(i)
Else
Set delRange = Union(delRange, .Rows(i))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.Delete
End With
End Sub
NOTE: I am assuming that a cell will have values like
String
aaa
bbb
ccc
String
If you have scenarios where the "String" can be in different cases or in between other strings for example
String
aaa
STRING
ccc
dddStringddd
then you will have to take a slightly different approach as shown in that link.
Autofilter code:
Sub QuickCull()
Dim rng1 As Range
Set rng1 = Range([d4], Cells(Rows.Count, "D").End(xlUp))
ActiveSheet.AutoFilterMode = False
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
With rng1
.AutoFilter Field:=1, Criteria1:="<>string"
If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then _
.Offset(1, 0).Resize(rng1.Rows.Count - 1).Rows.Delete
End With
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
ActiveSheet.AutoFilterMode = False
End Sub
When you want to delete rows its always better to delete from bottom.
Sub DeleteData()
Dim r As Long
Dim Rng As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("sheet1")
Set Rng = .Range(.Range("D1"), .Range("D1").End(xlDown))
For r = Rng.Rows.Count To 1 Step -1
If LCase(Trim(.Cells(r, 4).Value)) <> LCase("string") Then
.Cells(r, 4).EntireRow.Delete
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
This is a basic algorithm mistake.
Imagine your program are on, say, row 10. You delete it. So, row 11 becomes row 10, row 12 becomes 11 and so on. Then you go to row 11, skipping row 10, previous row 11!
This would work:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
Else
i = i + 1
End If
Loop
I'm trying to clear the contents of any cells within a column that contain the numbers 1-12. I'm currently using a for loop and an if statement, going one at a time through the numbers 1-12 and clearing the contents if the cell contains those values. The file I'm working with has over 35,000 rows of data; is there a more efficient way to tell the macro to delete those numbers without creating an individual elseif statement for them?
For r = 2 To i
If Cells(r, 1).Value = "1" Then
Cells(r, 1).ClearContents
ElseIf Cells(r, 1).Value = "2" Then
Cells(r, 1).ClearContents
You can use comparison operators combined with an And:
For r = 2 to i
If Cells(r, 1).Value >= 1 And Cells(r, 1).Value <= 12 Then
Cells(r, 1).ClearContents
End If
Next
Use a filter:
Sub tgr()
Dim ws As Worksheet
Set ws = ActiveWorkbook.ActiveSheet
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
With ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
.AutoFilter 1, ">=1", xlAnd, "<=12"
.Offset(1).ClearContents
.AutoFilter
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
The following code checks to see if any of my rows on the main page contain a date from a year ago or older. If it does, it copies it to the "Archive" worksheet and deletes it from the main page. However, what it's doing now is just copying from the main page and overriding what already exists on the archive page instead of adding to the last row. I've tried subbing in LastRow from a function, but I was getting an error with how I was using it. Anyone have a better solution?
Sub TestDateTransfer()
With Application
PrevCalc = .Calculation
.Calculation = xlCalculationManual
.Cursor = xlWait
.Calculate
.EnableEvents = False
.ScreenUpdating = False
End With
Application.DisplayAlerts = False
Worksheets("Archive").Activate
Range("A3:I1000").Select
Selection.ClearContents
Worksheets("Main Page").Activate
Dim MyDate As Date
MyDate = "03/27/2017"
Set i = Sheets("Main Page")
Set E = Sheets("Archive")
Dim d
Dim j
d = 2
j = 2
Do Until IsEmpty(i.Range("C" & j))
If i.Range("C" & j) <= MyDate - 365 Then
d = d + 1
E.rows(d).Value = i.rows(j).Value
End If
j = j + 1
Loop
Worksheets("Archive").Activate
ActiveSheet.Range("H1").Select 'To unselect the page
Worksheets("Main Page").Activate
MyDate = "03/27/2017"
Dim y
Dim z
y = 2
z = 2
Do Until IsEmpty(i.Range("C" & z))
If i.Range("C" & z) <= MyDate - 365 Then
y = y + 1
i.rows(z).Delete
End If
z = z + 1
Loop
With Application
.Cursor = xlDefault
.Calculate
.Calculation = PrevCalc
'.ScreenUpdating = True 'Not Needed...
.EnableEvents = True
End With
ActiveSheet.Range("H1").Select
End Sub
Worksheets("Archive").Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = "hai"
I have written a small piece of code that shows you how to use this. My code is different than yours b/c it loops through the range and checks each cell if the value of the difference between it and NOW is greater than or equal to 1 (which is how to tell if its from lats year or not). Its not how you approach it but it does seem to be more simplified in the approach. Alsoe I soted a bucnh of dates in a spreadsheet and tested this out. just apply to your needs. I hope this helps more?
Private Sub this()
Dim rng As Range
Dim rcell As Range
Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:A20")
For Each rcell In rng.Cells
'note that if you dont put a handler in here to deal with blank cells values this code will run forever. most peop-le do a check with "if rcell.valeu <> vbNullString then etc etc
If DateDiff("yyyy", rcell.Value, Now()) >= 1 Then
Worksheets("Sheet2").Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = rcell.Value
rcell.Value = vbNullString
End If
Next rcell
End Sub
You could exploit AutoFilter() method of Range object and copy/paste filtered rows in one shot:
Option Explicit
Sub main()
Dim MyDate As Date
MyDate = "03/27/2017"
Dim E As Worksheet
Set E = Worksheets("Archive")
With Worksheets("Main Page")
With .Range("C1", .Cells(.Rows.Count, "C").End(xlUp))
.AutoFilter field:=1, Criteria1:="<=" & CDbl((MyDate - 365))
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Intersect(.Parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy Destination:=E.Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With
.AutoFilterMode = False
End With
End Sub
I am running the following code on a spreadsheet:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
End If
i = i + 1
Loop
There are plenty of entries with not "String" but they do not get deleted.
When I copy this piece of code to a separate sheet, I even get the error "Excel cannot complete this task with available resources. Choose less data or close other applications."
What am I doing wrong that is making this loop not work?
Note: I can't use autofilter because I need to delete rows based on not meeting a condition.
This is the worst way to delete a row. Reasons
You are deleting the rows in a Loop
Your Cells Object are not qualified
Try this.
Co-incidentally I answered a similar question in the MSDN forum as well. Please See THIS
Try this way (UNTESTED)
In the below code I have hardcoded the last row to 100000 unlike as done in the above link.
Sub Sample()
Dim ws As Worksheet
Dim i As Long
Dim delRange As Range
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
For i = 1 To 100000
If .Cells(i, 4).Value <> "String" Then
If delRange Is Nothing Then
Set delRange = .Rows(i)
Else
Set delRange = Union(delRange, .Rows(i))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.Delete
End With
End Sub
NOTE: I am assuming that a cell will have values like
String
aaa
bbb
ccc
String
If you have scenarios where the "String" can be in different cases or in between other strings for example
String
aaa
STRING
ccc
dddStringddd
then you will have to take a slightly different approach as shown in that link.
Autofilter code:
Sub QuickCull()
Dim rng1 As Range
Set rng1 = Range([d4], Cells(Rows.Count, "D").End(xlUp))
ActiveSheet.AutoFilterMode = False
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
With rng1
.AutoFilter Field:=1, Criteria1:="<>string"
If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then _
.Offset(1, 0).Resize(rng1.Rows.Count - 1).Rows.Delete
End With
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
ActiveSheet.AutoFilterMode = False
End Sub
When you want to delete rows its always better to delete from bottom.
Sub DeleteData()
Dim r As Long
Dim Rng As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("sheet1")
Set Rng = .Range(.Range("D1"), .Range("D1").End(xlDown))
For r = Rng.Rows.Count To 1 Step -1
If LCase(Trim(.Cells(r, 4).Value)) <> LCase("string") Then
.Cells(r, 4).EntireRow.Delete
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
This is a basic algorithm mistake.
Imagine your program are on, say, row 10. You delete it. So, row 11 becomes row 10, row 12 becomes 11 and so on. Then you go to row 11, skipping row 10, previous row 11!
This would work:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
Else
i = i + 1
End If
Loop