I have sheet with data, i want to get data in other sheet but with conditions.For ex:
-------------------------------------------------
| Cell A | Cell B | Cell C | Cell D|Cell E |
|------------------------------------------------|
| Sku |Order_ID|Customer_ID | Price |Status |
|------------------------------------------------|
| TW22 | 123 | 1 |221 | D |
|------------------------------------------------|
| TS44 | 124 | 2 |221 | D |
|------------------------------------------------|
| Ts11-ab | 33 | 3 |211 | D |
|------------------------------------------------|
| Ts11 | 231 | 4 |231 | D |
|------------------------------------------------|
| Ts11-ab | 33 | 3 |211 | R |
|------------------------------------------------|
| Ts11 | 231 | 4 |231 | R |
|------------------------------------------------|
I have data in sheet as above in ex:, Now i want values like bellow in my other sheet ex:
-------------------------------------------------
| Cell A | Cell B | Cell C | Cell D|Cell E |
|------------------------------------------------|
| Sku |Order_ID|Customer_ID | Price |Status |
|------------------------------------------------|
| TW22 | 123 | 1 |221 | D |
|------------------------------------------------|
| TS44 | 124 | 2 |221 | D |
|------------------------------------------------|
| Ts11-ab | 33 | 3 |211 | R |
|------------------------------------------------|
| Ts11 | 231 | 4 |231 | R |
|------------------------------------------------|
I have tried vlookup and other formulas find from net but not helpful as i need.
update : If an order ID has two records in Sheet 1 with status “D” and “R”, it should show entry with just status “R” in the Sheet 2.And if there is only one record with status “D”, then it should show that record in the sheet 2. thanks
Note: I'm very new to VBA myself so this is messy, but should work.
Let RawData be the first sheet you mentioned with the full list with duplicates and let NewData be the second sheet with the "R"'s removed if a "D" exists.
Option Explicit
Sub RemoveDuplicates()
Dim i As Integer
i = 3
Worksheets("RawData").Activate
Range("A1:E2").Copy
Worksheets("NewData").Activate
Range("A1").Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
Do While Sheets("RawData").Cells(i, 1).Value <> ""
If Sheets("NewData").Range("A:A").Find(Sheets("RawData").Cells(i, 1), LookAT:=xlWhole) Is Nothing Then
Worksheets("RawData").Activate
Range(Cells(i, 1), Cells(i, 5)).Copy
Worksheets("NewData").Activate
Range("A1").End(xlDown).Offset(1, 0).Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
Else
Worksheets("RawData").Activate
Range(Cells(i, 1), Cells(i, 5)).Copy
Worksheets("NewData").Activate
Sheets("NewData").Range("A:A").Find(Sheets("RawData").Cells(i, 1), LookAT:=xlWhole).Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
End If
i=i+1
Loop
So what it does is check whether the item already exists in the list. If it does then it overwrites it with the new data.
Sorting and removing duplicates may help you.
rename sheet where you have data as "raw_data" and create new blank sheet in the same workbook named as "new_data". In sheet new_data" you will get the result.
Try below code
Sub copy_sheet()
Dim raw_data, new_data As Worksheet
Set raw_data = ThisWorkbook.Sheets("raw_data")
Set new_data = ThisWorkbook.Sheets("new_data")
raw_data.Activate
Range("A1:E1").Select
Range(Selection, Selection.End(xlDown)).Copy
new_data.Activate
Range("A1").PasteSpecial xlPasteValues
Range("A1").Sort key1:=Range("E1"), order1:=xlDescending, Header:=xlYes
Range("A1:E1").Select
Range(Selection, Selection.End(xlDown)).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
Range("A1").Sort key1:=Range("E1"), order1:=xlAscending, Header:=xlYes
Range("A1").Activate
End Sub
It sounds to me like you want to make use of the Dictionary class. This is packaged with VBA but isn't enabled by default -- you need to add it by adding a reference (Tools->References) to "Microsoft Scripting Runtime."
The Dictionary lets you store key-value pairs. I am assuming by your sample data that an "ORDER ID" constitutes a unique "record." If that's the case, this should work -- if not, just change the key to whatever defines a distinct record.
This code doesn't handle formatting, but you could easily manage that. This just shows you how to update values on old rows when new records appear.
Sub CopySheet()
Dim rw As Range
Dim findRow, newRow As Integer
Dim ws1, ws2 As Worksheet
Dim data As New Scripting.Dictionary
Dim status, orderId As String
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
newRow = 1
For Each rw In ws1.Rows
If ws1.Cells(rw.row, 1).Value2 = "" Then
Exit For
End If
orderId = ws1.Cells(rw.row, 2).Value2
status = ws1.Cells(rw.row, 5).Value2
If data.Exists(orderId) Then
findRow = data(orderId) ' found it -- replace existing
If status <> "R" Then ' if it's not "R", don't overwrite
findRow = 0
End If
Else
findRow = newRow ' never seen this order before
data.Add orderId, findRow ' add it to the dictionary
newRow = newRow + 1 ' add record on a new line
End If
If findRow > 0 Then
ws2.Range("A" & findRow & ":E" & findRow).Value = _
ws1.Range("A" & rw.row & ":E" & rw.row).Value
End If
Next rw
End Sub
Dictionaries are VERY efficient. This means if you have huge lists they don't suffer from the typical Excel performance lags like you do with a vlookup.
Related
I got 2 columns on 2 sheets of ~100000 cells long.
Those columns look like this:
---------
| 1 | a |
---------
| 2 | b |
---------
| 3 | c |
---------
| 4 | d |
---------
| 5 | e |
---------
and this:
---------
| 1 | a |
---------
| 3 | k |
---------
| 2 | b |
---------
| 4 | d |
---------
Now I am comparing the first columns to each other, if they match it has to check if the second column also matches. So the result will look like this:
---------------------
| 1 | a | correct |
---------------------
| 2 | b | correct |
---------------------
| 3 | c | wrong |
---------------------
| 4 | d | correct |
---------------------
| 5 | e | not found |
---------------------
I am using this function to do this: =IFERROR(IF(VLOOKUP(A3;newsheet!A:B;2;FALSE)=B3;"Correct";"Wrong");"Not Found") But to do this, it takes very long, I am using excel 2016 and all my 4 processors. Now it calculates slower and slower, probably because I got the first column on alphabetical order both, but the deeper it gets, the more rows it is going to check. So is there any way to let the VLOOKUP function not check the cells, it did already found an agreement.
So in my example: if it found the | 1 | a |, the next round it will search only the following remaining items:
---------------------
| 2 | b | correct |
---------------------
| 3 | c | wrong |
---------------------
| 4 | d | correct |
---------------------
| 5 | e | not found |
---------------------
Thanks in advance for helping me out with this problem
Unless you need the values to dynamically update; the VBA is a better alternative to 100K formulas. Using an ArrayList and arrays it took 1.98 seconds to process the data.
Sub ValidateData()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'You'll need to adjust these const values
Const LOOKUP_SHEET As String = "newsheet"
Const TARGET_SHEET As String = "oldsheet"
Dim x As Long, y As Long
Dim data As Variant, results As Variant
Dim key As String
Dim list As Object
Set list = CreateObject("System.Collections.ArrayList")
With Worksheets(LOOKUP_SHEET)
'Load the values from columns A and B into an array
data = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 2)
End With
For x = 1 To UBound(data, 1)
'Create a unique identifier
'using a delimiter to ensure value don't mix
key = data(x, 1) & "|" & data(x, 2)
If Not list.Contains(key) Then list.Add key
Next
With Worksheets(TARGET_SHEET)
'Load the values from columns A and B into an array
data = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 2)
'Resize the results array
ReDim results(1 To UBound(data), 1 To 1)
For x = 1 To UBound(data, 1)
'Create a unique identifier
'using a delimiter to ensure value don't mix
key = data(x, 1) & "|" & data(x, 2)
results(x, 1) = IIf(list.Contains(key), "Correct", "Wrong")
Next
.Range("C1").Resize(UBound(results, 1)) = results
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Can't post comments because of rep issues, but assuming they are sorted suitably this I think does what you ask.
Edit:
Also if you want to check both columns at once instead of going one at a time, you can join the two columns to make a proxy. i.e. Autofilling down =A1 & B1
So you get a third column containing
1a
2b
2c
etc.
Cuts the vlookups required in half :)
Sub ihopethishelps()
Dim last As Long
Dim r As Long
Range("B1").Select
Selection.End(xlDown).Select
last = ActiveCell.Row - 1
Range("C1").Select
For r = 0 To last
ActiveCell.Offset(r, 0).Value = _
"=IFERROR(IF(VLOOKUP(A" & r + 1 & ",Sheet2!A" & r + 1 & ":O" & last & ",2,FALSE)=B" & r + 1 & "," & Chr(34) & "Correct" & Chr(34) & "," & Chr(34) & "Wrong" & Chr(34) & ")," & Chr(34) & "Not Found" & Chr(34) & ")"
Next
End Sub
I have multiple worksheets:
1) Agent Sales
Name | Product | Sales
A | XX | $100
B | XX | $200
C | YY | $150
A | YY | $400
2) Agent Expense
Name | Product | Expense
A | XX | $10
B | XX | $20
C | YY | $15
A | YY | $80
The idea is to create a report on a separate worksheet per agent comparing them against the other agents for every single product. For example for Agent A:
> Sales
> Name | Product | Sales
> A | XX | $100
> B | XX | $200
>
> Expense
> Name | Product | Sales
> A | XX | $10
> B | XX | $10
>
>
> Sales
> Name | Product | Sales
> A | YY | $400
> C | YY | $150
>
> Expense
> Name | Product | Sales
> A | YY | $80
> C | YY | $15
I'm just trying to learn VBA and my first step to the problem is to have the copy and paste function working using autofiltered. Here's my code so far:
Sub Test()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sales")
ws.Rows(1).AutoFilter Field:=1, Criteria1:="A"
ws.Rows(1).AutoFilter Field:=2, Criteria1:="XX"
ws.Range("A2:C2", Range("A2:C2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Sheet2").Range("A1").PasteSpecial
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("Expense")
ws2.Rows(1).AutoFilter Field:=1, Criteria1:="A"
ws2.Rows(1).AutoFilter Field:=2, Criteria1:="XX"
ws2.Range("A2:C2", Range("A2:C2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Sheet2").Range("H1").PasteSpecial
End Sub
It returned a runtime error 1004 - method of range of object failed.
However, if i only copy paste just the sales table, the code worked.
I saw posts where VBA might delete the data on the clipboard, but given the sales table was successfully pasted, I'm not sure why second one giving out error.
Appreciate all the help/ideas.
In your following code line:
ws2.Range("A2:C2", Range("A2:C2").End(xlDown)).Copy
The Range is missing the Sheet reference, you need to add ws2, like this:
ws2.Range("A2:C2", ws2.Range("A2:C2").End(xlDown)).Copy
Copy the full code below, you will not get any errors (tested on my PC with your sample data you uploaded)
Sub TestCopyPaste()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sales")
ws.Rows(1).AutoFilter Field:=1, Criteria1:="A"
ws.Rows(1).AutoFilter Field:=2, Criteria1:="XX"
ws.Range("A2:C2", ws.Range("A2:C2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Sheet2").Range("A1").PasteSpecial
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("Expense")
ws2.Rows(1).AutoFilter Field:=1, Criteria1:="A"
ws2.Rows(1).AutoFilter Field:=2, Criteria1:="XX"
ws2.Range("A2:C2", ws2.Range("A2:C2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Sheet2").Range("H1").PasteSpecial
End Sub
I commented out the Field:=1 filter because you are trying to group by products not name and products.
Sub TestCopyPaste()
Dim NextRow As Long, x As Long
Dim Name As String, Product As String
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim ExpenseRange As Range
Worksheets("Report").Cells.Clear
For x = 2 To Worksheets("Sales").Range("A" & Rows.Count).End(xlUp).Row
Name = Worksheets("Sales").Cells(x, 1)
Product = Worksheets("Sales").Cells(x, 2)
If Not dict.Exists(Product) Then
NextRow = Worksheets("Report").Range("A" & Rows.Count).End(xlUp).Row
If NextRow > 1 Then NextRow = NextRow + 2
getFilteredData(Worksheets("Sales"), Name, Product).Copy Worksheets("Report").Cells(NextRow, 1)
Set ExpenseRange = getFilteredData(Worksheets("Expense"), Name, Product)
If Not ExpenseRange Is Nothing Then
NextRow = Worksheets("Report").Range("A" & Rows.Count).End(xlUp).Row + 2
ExpenseRange.Copy Worksheets("Report").Cells(NextRow, 1)
End If
dict.Add Product, vbNullString
End If
Next
Worksheets("Report").Columns.AutoFit
End Sub
Function getFilteredData(ws As Worksheet, Name As String, Product As String)
With ws
'.Rows(1).AutoFilter Field:=1, Criteria1:=Name
.Rows(1).AutoFilter Field:=2, Criteria1:=Product
Set getFilteredData = .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
End With
End Function
I have a spreadsheet like this:
Item Category | Customer Category
--------------|-------------------
A | Z
A | Z
A | Y
B | Y
B | Z
B | Z
etc.. on to > 35K rows.
I am trying to write a VBA module to count and merge rows which are the same in both columns, but keep coming up short.
I want output like:
Item Category | Customer Category | Count
--------------|--------------------|------
A | Z | 2
A | Y | 1
B | Y | 1
B | Z | 2
And so on...
It sounds so simple, and I found numerous examples on here sorting and counting much more complicated spreadsheets, but can't get mine to work.
Try this easy way using Advance Filter.
Sub Test()
Dim rng As Range, lrow As Long
With Sheet1
.Columns("E:G").ClearContents: .Range("G1") = "Count"
Set rng = .Range("A1", .Range("B" & .Rows.Count).End(xlUp))
rng.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range("E1"), Unique:=True
lrow = .Range("E" & .Rows.Count).End(xlUp).Row
With .Range("G2", "G" & lrow)
.Formula = "=COUNTIFS(A:A,E2,B:B,F2)"
.Value = .Value
End With
End With
End Sub
I think this is ok with 35k. So everytime you run the code, it will summarize items in Columns A and B to Columns E to G. Just something to get you started. And of course the easiest would be a Pivot Table as commented by Tim. HTH
Simply, the data looks like this:
ID | Value | Test | Score |
1 | 30 | a | b |
1 | 40 | c | d |
2 | 30 | d | a |
2 | 40 | e | c |
... for 130,000 lines. The value is always 30 or 40, i'd like to replace the 40, Test, and Score and put it in the row with 30 to look like this.
ID | Value | Test | Score | | | |
1 | 30 | a | b | 40 | c | d |
2 | 30 | d | a | 40 | e | c |
I can't seem to wrap my head around the offset-pasting of values. I've tried with Select.Copy,etc -and I have read nothing but bad things about going that route due to performance issues. Any help would be appreciative!
Thanks,
Dan
EDIT: Update -- So I've got it to work, but it will only go through 40 rows before I receive an overflow error. I know this is not optimized or at all the best way to do this - but it was the only thing I could do to figure it out. any input GREATLY appreciative.
I found out that there are a few instances where only 1 ID exists, thus I am checking to see if there are two IDs, if so - copy/paste, otherwise continue to the next row.
Sub Macro4()
' Macro4 Macro
Application.ScreenUpdating = False
Range("H6:K6").Select
Application.CutCopyMode = False
Selection.Copy
Range("L5").Select
ActiveSheet.Paste
Dim r As Integer, ID As Integer, validation As Integer
r = 5
While r < 400
Range("V1:X1").Select
Selection.ClearContents
Range("V1").Select
ID = Cells(r, 1).Value
Selection.Value = ID
Range("W1").Select
ActiveCell.FormulaR1C1 = "=countifs(C[-22],RC[-1])"
validation = Selection.Value
If validation > 1 Then
Cells(r + 1, 8).Select
Range(Selection, Cells(r + 1, 11)).Select
Selection.Copy
Cells(r, 12).Select
ActiveSheet.Paste
r = r + 2
End If
If validation = 1 Then
r = r + 1
End If
Wend
Application.ScreenUpdating = True
End Sub
Assuming ID is in A1, formulae should do it:
in E2 40
in F2 =C3
in G2 =D3
Copy down to suit (ensure 40 does not autoincrement), Select F:G, Paste Special, Values... over the top, filter to select 40 in ColumnB and delete selected rows.
I got it to work by changing:
Dim r As Integer, ID As Integer, validation As Integer
to:
Dim r As Integer, ID as Double, validation As Integer
I read somewhere that double holds significantly larger values -- appreciate all the help, regardless!
I'm a newbie. I have an excel file with 10 sheets, 6 sheets named after 6 employee names the next 3 with some information (irrelevant to my code) and the 10th sheet named Temp.
The employee sheets have the following data in each column (D&E are blank):
| A | B | C | D | E | F |
| 17-Sep-13 | ProjectA | 6 | | | Report updated on this day |
| 18-Sep-13 | CBL Ideas - HMF | 7 | | | |
| 18-Sep-13 | CBL Ideas - HMF | 1 | | | |
I want to have all these data collated in the sheet named Temp as follows:
| A | B | C | D |
| 17-Sep-13 | Project A | 6 | foo |
| 18-Sep-13 | Project A | 7 | foo |
| 18-Sep-13 | Project B | 1 | foo |
| 17-Sep-13 | Project A | 6 | bar |
| 18-Sep-13 | Project A | 7 | bar |
| 18-Sep-13 | Project B | 1 | bar |
Below is my code:
Sub ListRelevantEntries()
Dim s As Integer
Dim C As Range
For s = 1 To Worksheets.Count - 4
If Sheets(s).Cells(Rows.Count, "F").End(xlUp) _
.Value = "Report last updated on this day" Then
'Execution stops on the below line with an
' "Application-defined or object defined error"
Sheets(s).Range(Cells(Rows.Count, "F").End(xlUp) _
.Offset(1, 0), Cells(Rows.Count, _ "A").End(xlUp)) _
.Copy(Sheets("Temp").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0))
Sheets("Temp").Select
Sheets("Temp").Cells(Rows.Count, "C").End(xlUp).Offset(0, 1).Select
For Each C In Sheets("Temp").Range(Cells(Rows.Count,"C").End(xlUp). _
Offset(0, 1), Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)).Cells
C = Sheets(s).Name
Next
ElseIf Not Sheets(s).Cells(Rows.Count, "F").End(xlUp) _
.Value = "Report last updated on this day" _
And Not Sheets(s).Cells(Rows.Count, "F").End(xlUp).Value = "" Then
MsgBox "Extra Words entered " & ActiveSheet.Cells(Rows.Count, "F") _
.End(xlUp).Offset(1, 0).Value & " in " & Sheets(s).Name
End If
Next
Sheets("Temp").Range("1:1").Delete
End Sub
Sorry for such a long question. I couldn't think of any other way to explain!
The error will be a lot easier if you clean up your code. Add a worksheet variable at the start
Dim ws As Worksheet
Then after the first For statement assign the target sheet to it
Set ws = Worksheets(s)
Notice I used Worksheets(s) not Sheets(s). They are different, don't mix them. The Sheets collection can include Charts as well as Worksheets, it represents every tab. The Worksheets collection only contains Worksheet objects. In your For loop you used Worksheets, then you used Sheets within the loop. This will break if any charts are in the workbook.
Okay, so now that you have this ws variable containing a reference to the worksheet, go ahead and replace all your Sheets(s) with ws inside the for-loop's body. While you are at it, fix all your calls to Cells and Rows. Anywhere you write something like ws.Range(Cells(1, "F")) you are making a mistake. Cells alone points to ActiveSheet.Cells where as you want ws.Cells. Otherwise you are trying to create a cross-worksheet range any time ws is not ActiveSheet. The same goes for other properties of a range, such as Rows. So now the line of code you're stopping on should be more like this:
ws.Range(ws.Cells(ws.Rows.Count, "F").End(xlUp) _
.Offset(1, 0), ws.Cells(ws.Rows.Count, "A").End(xlUp)) _
.Copy Sheets("Temp").Cells(Sheets("Temp").Rows.Count, "A") _
.End(xlUp).Offset(1, 0)
Notice, I also removed the parentheses around the parameter you're passing to .Copy. In VBA you call a method without parentheses unless it returns a value. So MyMethod "Value to pass" or result = MyMethod("Value to pass") but not MyMethod("Value to pass").
After fixing all that, if it still is producing the error, I'd recommend using the debugger. Open the watch window and start breaking the offending line into bits, examine them, and find the problem.
So first you might create a watch for ws and make sure it's the correct sheet. Then maybe edit that watch to be ws.Cells(ws.Rows.Count, "F").End(xlUp) and see if that is getting the correct cell.
Oh, also, if you're doing it properly you shouldn't need to call anything like Worksheet.Select or .Activate. In fact, it's recommended you avoid those the vast majority of the time, unless you are interacting with the user by changing their view.
Replace with something like
With Sheets(s)
.Range(.Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0), .Cells(.Rows.Count, "A").End(xlUp)).Copy Sheets("Temp").Cells(Sheets("Temp").Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
you get the error since you did not return the reference to the sheet(s).
A quick fix is to add this:
Sheets(s).Select
prior line 6 or after line 4.
But for better coding, try using whats seen in This Thread.
That link discusses how you can avoid using select by declaring and setting all your objects.