I have been working on a macro that Archives: it selects rows with the right cell value and move them to another tab (while deleting the rows in the tab of origin).
My macro was working perfectly fine, but I decided to change my file and have different new tabs. When I computed my Macro in my new tabs, and it works on the right rows, and deletes them, but does not copy them in my "Archive tab" :
Sub Archive_Ongoing()
Test 2 : works for 2 arguments.
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("B90_Projects_OnGoing").UsedRange.Rows.Count
J = Worksheets("B90_Projects_Archived").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("B90_Projects_Archived").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("B90_Projects_OnGoing").Range("O1:O" & I)
Set yRg = Worksheets("B90_Projects_OnGoing").Range("T1:T" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Closed" And CStr(yRg(K).Value) <> "" Then
xRg(K).Selection.Copy Destination:=Worksheets("B90_Projects_Archived").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Closed" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub'
Any one would be able to explain why?
Because you're decrementing your K variable within the FOR loop, which is also incrementing it. Your K variable never changes. Comment out K = K - 1 and report back?
If you're doing that on purpose to evaluate / delete a single line and shift the next values up then you might want to have a K2 variable that you increment like this:
For K = 1 To xRg.Count
If CStr(xRg(K - K2).Value) = "Closed" And CStr(yRg(K - K2).Value) <> "" Then
xRg(K - K2).Selection.Copy Destination:=Worksheets("B90_Projects_Archived").Range("A" & J + 1)
xRg(K - K2).EntireRow.Delete
If CStr(xRg(K - K2).Value) = "Closed" Then
K2 = K2 + 1
End If
J = J + 1
End If
Next
Related
I've got a code that puts all the data of my Excel file (rows = 12,5k+ and columns = 97) in to a two-dimensional string. Then it loops through a certain column ("G") to list an listbox ("listbox1") with only unique findings.
Then in the Userform the user can choose to select some of the found items and transform it to another listbox ("Listbox2") Then when the user hits the button (CommandButton4) I would like the code to filter the array on only the rows where in column "G" it is the same as in one (or more) given criteria in listbox2.
It works when It has only one item in the listbox but when given two items in the listbox, it only returns everything blank.
Can some one please tell me what I'm doing wrong because I've no idea.
code:
Private Sub CommandButton4_Click()
Dim arr2() As Variant
Dim data As Variant
Dim B_List As Boolean
Dim i As Long, j As Long, q As Long, r As Long, LastColumn As Long, LastRow As Long
q = 1
r = 1
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet3")
Application.ScreenUpdating = False
Application.EnableEvents = False
With ThisWorkbook.Sheets("Sheet3")
LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
LastColumn = .Cells(3, Columns.Count).End(xlToLeft).Column
ReDim arr2(1 To LastRow, 1 To LastColumn)
For i = 2 To LastRow
For j = 1 To LastColumn
arr2(i, j) = .Cells(i, j).Value
Next j
Next i
End With
For i = 1 To LastRow
For j = 0 To Me.ListBox2.ListCount - 1
If ListBox2.List(j) = arr2(i, 7) Then
'Later aan te passen
Else
For q = 1 To LastColumn
arr2(i, q) = ""
Next q
End If
Next j
Next i
Sheets("Sheet3").UsedRange.ClearContents
For i = LBound(arr2, 1) To UBound(arr2, 1)
If arr2(i, 2) <> "" Then
r = r + 1
For j = LBound(arr2, 2) To UBound(arr2, 2)
ThisWorkbook.Sheets("Sheet3").Cells(r, j).Value = arr2(i, j)
Next j
End If
Debug.Print i, j, arr2(i, 7)
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
The issue is your second nested-loop:
For i = 1 To LastRow
For j = 0 To Me.ListBox2.ListCount - 1
If ListBox2.List(j) = arr2(i, 7) Then
'Later aan te passen
Else
For q = 1 To LastColumn
arr2(i, q) = ""
Next q
End If
Next j
Next i
Suppose that our ListBox has 2 values, "First" and "Second". For each row, you do the following:
j = 0
ListBox2.List(0) = "First"
If Column G is "First", do nothing
Otherwise, make the whole Row Blank Including if Column G = "Second"
At this point, the only possible values for Column G are now "First" or Blank
j = 1
ListBox2.List(1) = "Second"
If Column G is "Second", do nothing But, this cannot happen, because you have already changed any "Second" Rows to Blank
Otherwise, make the whole Row Blank
At this point, the Row will always be Blank
I recommend having a Boolean test variable. Set it to False at the start of each Row-loop, and set it to True if you find a match. If it is still False after you check all ListBox items, then blank the row:
Dim bTest AS Boolean
For i = 1 To LastRow
bTest = False 'Reset for the Row
For j = 0 To Me.ListBox2.ListCount - 1
If ListBox2.List(j) = arr2(i, 7) Then
bTest = True 'We found a match!
Exit For 'No need to keep looking
End If
Next j
If Not bTest Then 'If we didn't find a match
For q = 1 To LastColumn
arr2(i, q) = "" 'Blank the row
Next q
End If
Next i
I have two sheets data and PrevErrCheck. I am checking all occurrence of variable VarVal(this variable has data in E1 cell of PrevErrCheck) in sheet data and copy entire row to sheet PrevErrCheck. But the problem I am facing here is running macro multiple times overwriting data. I would like to keep the copied rows in sheet data and whenever I run next time, it should copy to next blank row.
I am using below code currently but bit confused to how to integrate the the option to find last row on PrevErrCheck and copy lines below that
Sub PrevErrCheck()
Dim spem As Workbook
Dim PrevErrCheck As Worksheet
Dim data As Worksheet
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
Set spem = Excel.Workbooks("SwitchPortErrorMonitor.xlsm")
Set PrevErrCheck = spem.Worksheets("PrevErrCheck")
Set data = spem.Worksheets("data")
spem.Worksheets("PrevErrCheck").Activate
VarVal = PrevErrCheck.Cells(1, "E").Value
I = data.UsedRange.Rows.count
J = PrevErrCheck.UsedRange.Rows.count
If J = 1 Then
If Application.WorksheetFunction.CountA(PrevErrCheck.UsedRange) = 0 Then J = 0
End If
Set xRg = data.Range("X:X")
On Error Resume Next
Application.ScreenUpdating = False
J = 3
For K = 1 To xRg.count
If CStr(xRg(K).Value) = VarVal And Not IsEmpty(VarVal) Then
xRg(K).EntireRow.Copy Destination:=PrevErrCheck.Range("A" & J + 1)
PrevErrCheck.Range("X" & J + 1).ClearContents
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
You have J = 3 before the loop, that may be a problem. xRg.count always returns 1048576, you should use something more specific. Try this:
Set spem = Excel.Workbooks("SwitchPortErrorMonitor.xlsm")
Set PrevErrCheck = spem.Worksheets("PrevErrCheck")
VarVal = PrevErrCheck.Cells(1, "E").Value
If IsEmpty(VarVal) Then Exit Sub
Set data = spem.Worksheets("data")
spem.Worksheets("PrevErrCheck").Activate
I = data.UsedRange.Rows.Count
J = PrevErrCheck.UsedRange.Rows.Count + 1
If J = 2 Then
If IsEmpty(PrevErrCheck.Cells(1, 1)) Then J = 1
End If
' If J = 1 Then
' If Application.WorksheetFunction.CountA(PrevErrCheck.UsedRange) = 0 Then J = 0
' End If
' Set xRg = data.Range("X:X")
' On Error Resume Next
' Application.ScreenUpdating = False
' J = 3
For K = 1 To I
If CStr(data.Cells(K, "X").Value) = VarVal Then
data.Cells(K, 1).EntireRow.Copy Destination:=PrevErrCheck.Range("A" & J)
PrevErrCheck.Range("X" & J).ClearContents
J = J + 1
End If
Next
' Application.ScreenUpdating = True
End Sub
I have a macro that moves row from one sheet to another one once I time the word "Completed" in a certain field.
The problem is that it moves row into a wrong place. I have 212 rows on another worksheet, the next row should be moved row #213 on another sheet, but it moves all the way to the row #654.
Please help me to resove the issue, so each row will move to the next available row on another worksheet.
Here is my VBA code:
Sub Autoupdating()
'Move shipments once completed
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Scheduled Shipments").UsedRange.Rows.Count
J = Worksheets("Completed Shipments").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Completed Shipments").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Scheduled Shipments").Range("G1:G" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Completed" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Completed Shipments").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Completed" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
The problem looks like you aren't resetting J when you move from one worksheet to the next. So if you first sheet had 652 rows, it will place the last row on line 653 (J + 1 = 653). But, when you start moving rows on the second sheet, it will start placing them at 654 (653 + 1 = 654).
Try to add the following part into your into your code, removing the commented lines as shown:
'Your previous code ---^
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Completed" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Completed Shipments").Range("A" & J + 1)
'xRg(K).EntireRow.Delete
'If CStr(xRg(K).Value) = "Completed" Then
' K = K - 1
'End If
J = J + 1
End If
Next
'this is the new code ---v
For K = xRg.Count To 1 Step -1
If CStr(xRg(K).Value) = "Completed" Then
xRg(K).EntireRow.Delete
End If
Next K
'end of the new code ---^
Application.ScreenUpdating = True
End Sub
Whenever you are feeling that the code you are writing does not do what it intends to do, it is a good idea to simplify.
In this case, you may split the task into two sub-tasks:
Copy the rows with "Completed" to a specific worksheet
Delete the rows with the word "Completed"
Note that in order to delete rows correctly from a worksheet, it is a better idea to loop from the bottom and not from the top, thus the loop is reversed.
I solved it on my own. I added a for loop. Here is my working code. Thanks to everyone else for trying to help.
Sub runMatch()
Dim critRemID, listRemID, critRemIDstart, listRemIDstart As Range
Set critRemID = Worksheets("Enterprise - score").Cells(2, 1)
Set listRemID = Worksheets("Sheet1").Cells(2, 1)
Set critRemIDstart = Worksheets("Enterprise - score").Cells(2, 30)
Set listRemIDstart = Worksheets("Sheet1").Cells(2, 2)
Dim i, j, index As Integer
i = 0
j = 0
Do While critRemID.Offset(i, 0) <> ""
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
For index = 0 To 84
critRemIDstart.Offset(i, index) = listRemIDstart.Offset(j, index).Value
Next index
i = i + 1
j = 0
index = 0
Else
If listRemID.Offset(j, 0) = "" Then
j = 0
i = i + 1
Else
j = j + 1
End If
End If
Loop
End Sub
I have two sheets, they each have a the same IDs on each sheet but
different sets of data.
I want to scan through the rows of data and if there is a match, copy
the entire row from a certain column to another certain column to the
end of one of the sheets.
Sheet 1 is the sheet I want to copy info into, on the end I've created
the same headers for the data I want to bring over from sheet 2.
the code below is what I have, I set a range up for the IDs and one
for where I want the copied cells to start
Dim critRemID, listRemID, critRemIDstart, listRemIDstart As Range
Set critRemID = Worksheets("Enterprise - score").Cells(2, 1)
Set listRemID = Worksheets("Sheet1").Cells(2, 1)
Set critRemIDstart = Worksheets("Enterprise - score").Cells(2, 30)
Set listRemIDstart = Worksheets("Sheet1").Cells(2, 90)
Dim i, j As Integer
i = 0
j = 0
Do While critRemID.Offset(i, 0) <> ""
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
critRemIDstart.Row(i) = listRemIDstart.Row(j).Value
i = i + 1
j = 0
Else
j = j + 1
End If
Loop
I keep getting this error
Wrong number of arguments or invalid property assignment
I tried going a different route but kept getting confused as shown
below. I was trying to have it copy each cell one by one and once it
reached an empty cell, it would move onto the next ID on the main
sheet and start over but this does nothing, I think it keeps
increasing both IDs on the sheet and never finds a match.
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
critRemIDstart.Offset(i, k) = listRemIDstart.Offset(j, l).Value
k = k + 1
l = l + 1
Else
If listRemIDstart.Offset(j, l) = "" Then
j = j + 1
l = 0
i = i + 1
k = 0
Else
j = j + 1
i = i + 1
l = 0
k = 0
End If
End if
any help is appreciated. Thanks.
Range.Find method could find the key easily.
Dim critRem, listRem As Worksheet
Set critRem = Worksheets("Enterprise - score")
Set listRem = Worksheets("Sheet1")
Dim critRemID, listRemID, cell, matchedCell As Range
With critRem
Set critRemID = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With listRem
Set listRemID = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
For Each cell In critRemID
Set matchedCell = listRemID.Find(cell.Value)
If matchedCell Is Nothing Then 'ID is not found
'Do nothing
Else 'ID is found, matchedCell is pointed to column A now
cell.Offset(0, 29).Resize(1, 10) = matchedCell.Offset(0, 89).Resize(1, 10)
'offset(0,29) means offsetting right 29 columns
'resize(0,10) means resizing the range with 1 row and 10 columns width
'feel free to change the number for your data
End If
Next cell
Note: If you are confused about offset().resize(), there is another approach. cell.Row gives you the row that the data should be written into, and matchedCell.Row gives you the row that the ID matched. So you can access certain cell by something like listRem.Range("D" & matchedCell.Row)
Tried to do it using the loop.
Sub Anser()
Dim critRemID As Range
Dim listRemID As Range
Dim critRemIDstart As Range
Dim listRemIDstart As Range
'::::Change Sheet names and column numbers:::::
Set critRemID = Worksheets("Sheet1").Cells(2, 1)
Set listRemID = Worksheets("Sheet2").Cells(2, 1)
Set critRemIDstart = Worksheets("Sheet1").Cells(2, 2)
Set listRemIDstart = Worksheets("Sheet2").Cells(2, 2)
Dim i, j As Integer
i = 0
j = 0
Do
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
critRemIDstart.Offset(i) = listRemIDstart.Offset(j)
i = i + 1
j = 0
Else
j = j + 1
End If
Loop While critRemID.Offset(i, 0) <> ""
End Sub
If as you say both sheets have the same IDs, then why not use a Vlookup function to bring the data into Sheet1, then simply copy the results and paste as values so you get rid of the formula on them cells?
Something like a loop running:
For i = 1 to LastRow
Sheet1.cells(i, YourColumnNumber).value = "=VLOOKUP(RC[-1], Sheet2!R1:R1048576, 3, False)"
Next i
I'm trying to use "j" as a counter for columns. I tried using it as follows, but in what I have "j" is representing a row. The macro works, but only copies row 25 - 27.
Can anyone tell me how to use this with j as the column number? Also, how would I copy this so that the column width is also retained?
Sub CopyFinal()
Set i = Sheets("MedicalBenefits")
Set e = Sheets("Final")
Dim j As Integer
j = 2
Application.ScreenUpdating = False
Do Until IsEmpty(i.Cells(5, j))
i.Range(j & "5:" & j & "27").Copy e.Range(j & "5:" & j & "27")
j = j + 1
Loop
Application.ScreenUpdating = True
End Sub
switch to Cells(rowIndex, columnIndex) syntax to use integer columns index
Do Until IsEmpty(i.Cells(5, j))
i.Cells(5, j).Resize(23).Copy e.Cells(5, j)
j = j + 1
Loop
Use Offset()
j = 0
Application.ScreenUpdating = False
Do Until IsEmpty(range("B5").offset(0,j))
i.Range("B5:B27").Offset(0,j).Copy e.Range("B5:B27").Offset(0,j)
j = j + 1
Loop