Copy Range, Offset Paste through entire file VBA - vba

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!

Related

Excel. copy text string and number of repeats to new columns

Given two columns (A and B), one with a text and one with an integer, such as:
A | B
pen | 3
pen | 5
How could I fill the columns C, D, E [...] with the concatenation of the given string on each row with all integers starting from 1 until the specified number?
The desired output for the given example would be:
A | B | C | D | E | F | G
pen | 3 | pen01 | pen02 | pen03 | |
pen | 5 | pen01 | pen02 | pen03 | pen04 | pen05
With a simple vba sub this can be achieved:
Sub CreateValues
With ActiveSheet
Dim LastRow as Long: LastRow = .Range("A" & .Rows.Count).End(xlup).Row
For i = 1 To LastRow
Max_Num = .Cells(i, 2)
For j = 1 to Max_Num
.Cells(i, j + 2) = .Cells(i, 1) & Format(j, "00")
Next j
Next i
End With
End Sub
If you are looking for a formula solution without needing to resort to VBA, you can use this formula in C1 and drag in both dimensions:
=IF(COLUMNS($C1:C1)<=$B1,CONCATENATE($A1,TEXT(COLUMNS($C1:C1),"00")),"")

How to delete found values from Vlookup function but not from excel itself, so the vlookup wont search the cells again

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

Get values from othersheet to other based on conditions in excel

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.

Excel VBA - Get row of latest change in a parameter

I have a large data set which looks like this:
Employee ID |Job| Function| Level|Date of change
1 | x | a | A1 | 01/05/2014
1 | y | a | A1 | 02/04/2015
1 | y | a | A2 | 25/08/2015
1 | z | a | A3 | 27/12/2015
1 | z | c | A3 | 01/03/2016
2 | t | b | B1 | 12/05/2013
2 | v | b | B1 | 13/04/2014
2 | w | b | B3 | 12/01/2016
Each row contains a change in either job, function or level.
I need to create a table which puts together the latest change in level for each employee (so for employee 1, it would be row 4). So far I have used a combination of conditional formatting and pivots but I was wondering if there is a way to do this quicker in VBA.
Thanks!
Without VBA
This assumes that there are genuine dates in column E with format dd/mm/yyyy, In G1 enter the Array Formula:
=MAX(IF(A:A=1,E:E,""))
This gives the latest date for employee 1
Array formulas must be entered with Ctrl + Shift + Enter rather than just the Enter key.
Then in G2 enter:
=SUMPRODUCT(--(A1:A9=1)*(E1:E9=G1)*(ROW(1:9)))
This gives the row number of the record you are interested in.
From there you can use INDEX() to get any information from that row.
NOTE:
The formulas in G1 and G2 can be combined into a single cell if desired.
EDIT#1:
The same set of formulas should work with text values for the employee id as well as numbers:
Not sure this is the best solution, but since this is a one-off exercise and it did the trick I used this:
VBA to find all the rows where there was a change in level, and write a "yes" in column "F" where applicable:
Sub JLChange()
Dim Data As Worksheet
Dim i As Long
Dim lastrow As Long
Set Data = ThisWorkbook.Worksheets("Data")
lastrow = Data.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastrow
If Cells(i + 1, 4).Value <> Cells(i, 4).Value And_
Cells(i + 1,1).Value = Cells(i, 1).Value Then
Cells(i + 1, 6).Value = "Yes"
Else
Cells(i + 1, 6).Value = "No"
End If
Next i
End Sub
For all the records in column "F", I used the formulas suggested by Gary's student to get the very last change.
Alternatively, you can copy-paste this database of changes in a new sheet, sort by ID and by date of change from newest to oldest, then use vlookup to get the first entry for each ID.

how to find the max 'n' values for data based on SUM of values?

Below is the table
Amt | Val | Location
230 | a | DEL
450 | b | KOL
670 | c | BLR
890 | d | DEL
111 | e | KOL
133 | a | KOL
155 | b | DEL
177 | c | BLR
199 | a | DEL
221 | b | BLR
243 | c | BLR
265 | d | KOL
287 | a | KOL
309 | b | DEL
331 | c | DEL
353 | d | KOL
375 | e | BLR
397 | a | BLR
419 | b | DEL
441 | c | KOL
out of a,b,c,d,e values how to find the maximum 2 values for respective location based on the a's..b's..c's..d's..e's amount.
I am able to get the sum of values of top 2 val through Pivot table, for one location
Please tell how to get the top 2 val with their sum of amount for all location simultaneously through VBA,
I have Posted VBA code for the same, which gives result for only one location.
Sorry not able to upload the snapshot.
Say your data is in A1 thru C20. You have three unique locations: DEL, KOL, BLR.
In D1 enter:
=SUMPRODUCT(--(A$1:A$20)*(C$1:C$20=C1)) and copy down thru D3
In E1 enter:
=LARGE(D1:D3,1)
In E2 enter:
=LARGE(D1:D3,2)
Should look like:
EDIT:
based upon your comment, the highest two values for DEL would be:
=LARGE(IF(C1:C20="del",A1:A20),1)
and
=LARGE(IF(C1:C20="del",A1:A20),2)
These are array formulas that must be entered with CNTRL-SHFT-ENTER rather than just the ENTER key
DMAX function returns the largest number in a column in a list or database, based on a given criteria.
http://www.techonthenet.com/excel/formulas/dmax.php
1. Insert a Pivot Table.
2. Add Val in Row Labels.
3. Add Location in column Labels.
4. Add Amt in Values field(Sumof Amt).
Now In created Pivot Table,
1. In column labels filter for only one location(eg: Blr).
2. In Row Labels filter apply value filters and select Top 10..(last item).
3. In place of 10(by default) give 2.
4. Now the table consists of Top 2 val with their sum of Amount for BLR Location.
VBA Code for the Same:
Private Sub CommandButton1_Click()
Dim wkbk As Workbook
Set wkbk = ActiveWorkbook
With wkbk.Sheets(1)
LastRow = .Range("A1").End(xlDown).Row
LastCol = .Range("A1").End(xlToRight).Column
Set rngSource = .Range("A1", .Cells(LastRow, LastCol))
End With
With wkbk.Sheets(2)
Set dst = .Range("a1")
End With With wkbk
Sheets(1).PivotTableWizard _
SourceType:=xlDatabase, _
SourceData:=rngSource, _
TableDestination:=dst, _
TableName:="Pivotinfo"
End With
With wkbk.Sheets(2).PivotTables("Pivotinfo")
.PivotFields("Val").Orientation = xlRowField
.PivotFields("Location").Orientation = xlColumnField
With .PivotFields("Amt")
.Orientation = xlDataField
.Function = xlSum With wkbk.Sheets(2).PivotTables("Pivotinfo").PivotFields("Location")
.PivotItems("DEL").Visible = False
.PivotItems("KOL").Visible = False
End With
With wkbk.sheets(2).PivotTables("Pivotinfo").PivotFields("Val").AutoShow _
xlAutomatic, xlTop, 2, "Sum of Amt"
End With
End With
End With
End Sub