I've been looking through the website and have not found a similar situation yet. Specifically, what I'm looking to do is the following.
Using the table with three columns,
Number Priority Age
1234567890 Low 1
1234567890 Low 2
1234567890 High 3
1234567890 High 4
I would like a VBA macro that will first copy the oldest record (determined by the age column), send it over to the current sheet, then delete that record from the main sheet, followed by saving the Excel file.
Again, I have not found anything near this just yet since all the ones I've seen copy ALL rows instead of specifics.
Any help would be amazing!
Edit: Here's the VBA code I tried using but I keep getting the same results (all rows being copied).
code
Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
For Each cell In Sheets("master").Range("A:A")
If (Len(cell.Value) = 0) Then Exit For
For i = 0 To UBound(aTokens)
If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
iMatches = (iMatches + 1)
Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
End If
Next
Next
End Sub
code
Assuming this just wanted to be runned once, this will work. Not sure why you are using arrays. Your table have 3 columns, but you are saying two! Anyway this is working on your table.
Sub Move_Oldest()
Dim Rng As Range
Dim Lrow As Long
Dim Trow as long
Lrow = Sheets("top10").Range("a1000000").End(xlUp).Row
With Sheets("master")
Set Rng = Intersect(.UsedRange, .Columns(3))
If Not Rng Is Nothing Then
trow = Application.Match(Application.Max(Rng), Rng, 0)
.Cells(trow, 1).Resize(, 3).Copy Sheets("top10").Cells(Lrow + 1, 1)
.rows(trow).delete
End If
End With
End Sub
Related
I have what I thought would be a simple script, but I have some some strange results.
Goal: Identify specific IDs in a SOURCE sheet using a list of IDs on a Translator Sheet. When found, copy the entire row to and OUTPUT sheet.
The output has strange results that I can't figure out.
Returns all results instead of the limited list. AND results are in weird groupings. (First result is on row 21 and only has 9 rows of data, the next group has 90 rows of data, starting on row 210, then blank rows, then 900 rows of data, etc.
Results do not start in row 2.
Full code is below attempts:
Attempts:
I first searched the SOURCE sheet based on one ID that was hard coded as a simple test and it worked. but when I changed the code to search a range (z21:z), two things happened: 1, it returns everything in the Source file in multiples of 9 as stated above, AND as you can imagine, the time to complete skyrocketed from seconds to minutes. I think I missed a add'l section of code to identify the range??
Old Code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("D62D627EB404207DE053D71C880A3E05") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
New code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I)** Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
1a. I believe one issue is that the Translator list has duplicates. Second, it is searching the entire column Z. Second issue may be that The list in Translator is generated via a formula in column Z, thus if the formula is false, it will insert a "" into the cell. I seek the code to NOT paste those rows where the cell content is either a "" or is a true blank cell. Reason: The "" will cause issues when we try to load the Output file into a downstream system because it is not a true blank cell.
Results in wrong location: When the script is complete, my first result does not start on Row 2 as expected. I thought the clear contents would fix this, but maybe a different clear function is required? or the clear function is in the wrong place? Below screenshot shows how it should show up. It is in the same columns but doesn't start until row 21.
enter image description here
Slow code: I have a command that copies and pastes of the first row from SOURCE to OUTPUT. My code is cumbersome. There has to be an easier way. I am doing this copy and paste just in case the source file adds new columns in the future.
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Thank you for all your help.
Option Explicit
Sub MoveRowBasedOnCellValuefromlist()
'Updated by xxx 2023.01.18
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("SOURCE").UsedRange.Rows.Count
J = Worksheets("Output").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Output").UsedRange) = 0 Then J = 0
End If
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Set xRg = Worksheets("SOURCE").Range("B2:B" & I)
On Error Resume Next
Application.ScreenUpdating = False
'NOTE - There are duplicates in the Translator list. I only want it to paste the first instance.
'Otherwise, I need to create an =Unique() formula and that seems like unnecessary work.
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I) Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Try this out - using Match as a fast way to check if a value is contained in your lookup list.
Sub MoveRowBasedOnCellValuefromlist()
Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
Dim cDest As Range, wsTrans As Worksheet, rngList As Range
Set wb = ThisWorkbook 'for example
Set wsSrc = wb.Worksheets("SOURCE")
Set wsOut = wb.Worksheets("Output")
Set wsTrans = wb.Worksheets("Translator")
Set rngList = wsTrans.Range("Z21:Z" & wsTrans.Cells(Rows.Count, "Z").End(xlUp).Row)
ClearSheet wsOut
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("A2") 'first paste destination
Application.ScreenUpdating = False
For Each c In wsSrc.Range("B2:B" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells
If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
c.EntireRow.Copy cDest
Set cDest = cDest.Offset(1) 'next paste row
End If
Next c
Application.ScreenUpdating = True
End Sub
'clear a worksheet
Sub ClearSheet(ws As Worksheet)
With ws.Cells
.ClearContents
.ClearFormats
End With
End Sub
I have been given a work task where im to find and replace 8 digits numbers with a corresponding new values coming from a 2 column table....basically a vlookup then replace the old value with a new one...
The challenge im facing is.... the 2 column table is 882k rows, and the cells im trying to replace is about 120 million (41,000 rows x 3000 columns)...
I tried running a vba code i found somewhere...
Option Explicit
Sub Replace_Overwrite()
Dim LRow As Long, i As Long
Dim varSearch As Variant
With Sheets("Sheet2")
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
varSearch = .Range("A2:B" & LRow)
End With
With Sheets("Sheet1").UsedRange
For i = LBound(varSearch) To UBound(varSearch)
.Replace what:=varSearch(i, 1), replacement:=varSearch(i, 2), lookat:=xlWhole
Next
End With
End Sub
I tried using this and it ran it for 8 hours and my work laptop crashed....
I'm not sure anymore if this is still possible with MS Excel alone...
I wonder if anyone can help me with a code that can process it.. i can leave my system open over the weekend if its stable and does work.. it only has 8GB ram btw, running excel 2013...
To speed up things, do as much as possible in memory and minimize the interaction between VBA and Excel (as this makes things really slow).
The following attempt reads the lookup-list into a dictionary and then processes the data column by column.
I did a test, creating 880.000 lookup rows and 40.000 x 100 cells of data. Building the dictionary took less than a minute, processing the columns took 3-4 seconds per column. I added a logic that after every 10 columns, the whole workbook is saved, that increased the processing time but ensures that after a crash you can more or less continue where you left (the yellow color tells you where, just replace the 1 in for col=1 with the column where you want to restart).
I have added some DoEvents, that in theory slows down the process a little bit. Advantage is that you can see the output of the debug.print and the whole Excel process is not displayed as unresponsive in the task manager.
To build the dictionary, I read the complete data into an array at once (if you are not familiar with Dictionaries: You need to add a reference to the Microsoft Scripting Runtime).
Function createDict() As Dictionary
Dim d As New Dictionary
Dim rowCount As Long
Dim list()
Debug.Print Now, "Read data from Lookup sheet"
With ThisWorkbook.Sheets(1)
rowCount = .Cells(.Rows.Count, 1).End(xlUp).row
list = .Range("A1:B" & rowCount).Value
End With
Debug.Print Now, "Build dictionary."
Dim row As Long
For row = 1 To UBound(list)
If Not d.Exists(list(row, 1)) Then d.Add list(row, 1), list(row, 2)
If row Mod 1000 = 0 Then DoEvents
Next row
Set createDict = d
End Function
As said, replacing the data is done column by column. Again, I read the whole column at once into an array, do the replace on this array and then write it back to the sheet.
Sub replaceAll()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim d As Dictionary
Set d = createDict
Dim row As Long, col As Long
Dim rowCount As Long, colCount As Long
With ThisWorkbook.Sheets(2)
rowCount = .Cells(.Rows.Count, 1).End(xlUp).row
colCount = .Cells(1, .Columns.Count).End(xlToLeft).Column
For col = 1 To colCount
Debug.Print Now & "processing col " & col
DoEvents
Dim data
data = .Range(.Cells(1, col), .Cells(rowCount, col))
For row = 1 To rowCount
If d.Exists(data(row, 1)) Then data(row, 1) = d(data(row, 1))
Next row
.Range(.Cells(1, col), .Cells(rowCount, col)) = data
.Cells(1, col).Interior.Color = vbYellow
If col Mod 10 = 0 Then ThisWorkbook.Save
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
One remark: You should consider to use a database for such amount of data.
I have a problem...
I have two datasets in the same workbook on different sheets.
The first column in both datasets are identifiers. In Sheet1 I have my dataset, and want to fill it with data from Sheet2 (which is also containing data (rows+Columns) that I do not want to use.
I have a VBA that is working, BUT, it stops before it is done.
E.g. I have 1598 Rows in Sheet2, but it stops working already after 567 rows..
Sub Test()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Sheet2")
Set Target = ActiveWorkbook.Worksheets("Sheet1")
j = 2
For Each c In Source.Range("A2", Source.Range("A" & Source.Cells(Source.Rows.Count, "A").End(xlUp).Row))
If c = Target.Cells(j, 1).Value Then
Source.Range("D" & c.Row & ":AS" & c.Row).Copy Target.Cells(j, 26)
j = j + 1
End If
Next c
MsgBox "Done"
End Sub
Can someone help me and see if there is something obviously wrong with the code? I have tried it on smaller datasets, and then it works perfect.
If more information needed or you have some other tips, please ask/tell :D
Thanks!
VBA Solution
Try the following, it usese the WorksheetFunction.Match method to properly match the values of column A no matter which order they are.
It loops through all rows in Target, and tries to find a matching row in Source. If a match was found it copies it into the Target.
Option Explicit
Public Sub Test()
Dim Source As Worksheet
Set Source = ThisWorkbook.Worksheets("Sheet2")
Dim Target As Worksheet
Set Target = ThisWorkbook.Worksheets("Sheet1")
Dim LastRowTarget As Long
LastRowTarget = Target.Cells(Target.Rows.Count, "A").End(xlUp).Row
Dim tRow As Long
For tRow = 2 To LastRowTarget
Dim sRowMatch As Double
sRowMatch = 0 'reset match row
On Error Resume Next 'ignore if next line throws error
sRowMatch = Application.WorksheetFunction.Match(Target.Cells(tRow, 1).Value, Source.Columns("A"), 0)
On Error GoTo 0 're-enable error reporting
If sRowMatch <> 0 Then 'if matching does not find anything it will be 0 so <>0 means something was found to copy
Source.Range("D" & sRowMatch & ":AS" & sRowMatch).Copy Target.Cells(tRow, 26)
End If
Next tRow
MsgBox "Done"
End Sub
Formula Solution
Note that there is no need for VBA and this could actually also solved with formulas only. Either the VLOOKUP formula or a combination of INDEX and MATCH formula.
So in Sheet1 cell Z2 write =INDEX(Sheet2!D:D,MATCH($A2,Sheet2!$A:$A, 0)) and pull it down and right.
I have an excel file which looks like this:
row1_cell1 row1_cell2 row1_cell3
row2_cell1 row2_cell2 row2_cell3
row3_cell1 row3_cell2 row3_cell3
How can i make three (or any number of) copies of each row that i have in the sheet, which i would like to be added after the row being copied? So, in the end i would like to have this kind of a result:
row1_cell1 row1_cell2 row1_cell3
row1_cell1 row1_cell2 row1_cell3
row1_cell1 row1_cell2 row1_cell3
row2_cell1 row2_cell2 row2_cell3
row2_cell1 row2_cell2 row2_cell3
row2_cell1 row2_cell2 row2_cell3
row3_cell1 row3_cell2 row3_cell3
row3_cell1 row3_cell2 row3_cell3
row3_cell1 row3_cell2 row3_cell3
This is how I would do that for all rows on the sheet:
Option Explicit
Sub MultiplyRows()
Dim RwsCnt As Long, LR As Long, InsRw As Long
RwsCnt = Application.InputBox("How many copies of each row should be inserted?", "Insert Count", 2, Type:=1)
If RwsCnt = 0 Then Exit Sub
LR = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For InsRw = LR To 1 Step -1
Rows(InsRw).Copy
Rows(InsRw + 1).Resize(RwsCnt).Insert xlShiftDown
Next InsRw
Application.ScreenUpdating = True
End Sub
There isn't a direct way to paste them interleaved like what you wanted. However, you can create a temporary VBA to do what you want.
For example, you can:-
Create a VBA procedure (like the one below) in your Excel file.
Assign a keyboard shortcut (eg. Ctrl+Q) to it.
To do this, press Alt+F8, then select the macro, then click 'Options'.
Select the cells you want to copy, then press Ctrl+C.
Select the cell you want to paste in, then press Ctrl+Q (or whatever keyboard shortcut you chose).
Enter the number of times you want to copy. (In your example, it would be 3.)
WHAMMO! :D
Now you can delete the VBA procedure. :)
VBA Code:
Sub PasteAsInterleave()
Dim startCell As Range
Dim endCell As Range
Dim firstRow As Range
Dim pasteCount As Long
Dim rowCount As Long
Dim colCount As Long
Dim i As Long
Dim j As Long
Dim inputValue As String
If Application.CutCopyMode = False Then Exit Sub
'Get number of times to copy.
inputValue = InputBox("Enter number of times to paste interleaved:", _
"Paste Interleave", "")
If inputValue = "" Then Exit Sub 'Cancelled by user.
On Error GoTo Error
pasteCount = CInt(inputValue)
If pasteCount <= 0 Then Exit Sub
On Error GoTo 0
'Paste first set.
ActiveSheet.Paste
If pasteCount = 1 Then Exit Sub
'Get pasted data information.
Set startCell = Selection.Cells(1)
Set endCell = Selection.Cells(Selection.Cells.count)
rowCount = endCell.Row - startCell.Row + 1
colCount = endCell.Column - startCell.Column + 1
Set firstRow = Range(startCell, startCell.Offset(0, colCount - 1))
'Paste everything else while rearranging rows.
For i = rowCount To 1 Step -1
firstRow.Offset(i - 1, 0).Copy
For j = 1 To pasteCount
startCell.Offset(pasteCount * i - j, 0).PasteSpecial
Next j
Next i
'Select the pasted cells.
Application.CutCopyMode = False
Range(startCell, startCell.Offset(rowCount * pasteCount - 1, colCount - 1)).Select
Exit Sub
Error:
MsgBox "Invalid number."
End Sub
Old thread, however someone might find this useful:
The below information was copied from here
I needed to do almost the opposite. I needed the formula to increment by 1 every 22 rows, leaving the 21 rows between blank. I used a modification of the formula above and it worked great. Here is what I used:
=IFERROR(INDIRECT("J"&((ROW()-1)*1/22)+1),"")
The information was in column "J".
The "IFERROR" portion handles the error received when the resulting row calculation is not an integer and puts a blank in that cell.
Hope someone finds this useful. I have been looking for this solution for a while, but today I really needed it.
Thanks.
I'm not new to Excel VBA but not an expert too. I'm in strange problem, someone plz help me I'm not able to think anymore.
My Excel Story:
I have some 40,000 rows in a spreadsheet. rows are in the pattern mentioned as below:
row1) Source > AppName1
row2) Destination > corresponding value1
row3) Destination > corresponding value2
row4) Source > AppName2
row5) Destination > corresponding value3
row6) Source > AppName3
row7) Destination > corresponding value1
Now if search by AppName let's be AppName1 then row2 and row3 should be copied to next sheet along with row1.
If I search for Value1 then it should get row1, row2, row3 row7 and row6 should be copied to next sheet. That means search strings precedents and descendent's rows should be copied to next sheet.
I cannot provide the sample sheet as my reputation points are less than 10.
Is there anyone who can guide and assist me I have spent my 3 days in this but not got any result.
I have a very critical schedule for preparing this inventory sheet I was doing it manually and it was taking 5-6days to do manually. I thought of automizing it but got stuck.
Here is my code that is not working:
Sub GenerateInventory()
On Error GoTo ErrHandler:
Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
Set r1 = Cells(2, 8)
For i = 2 To nLastRow Step 1
If InStr(Cells(i, 6), "CMRI") <> 0 Then
Set r1 = Union(r1, Cells(i, 1))
End If
Next
r1.EntireRow.Select
r1.EntireRow.Copy
Sheets("MS4Inventory").Select
Cells(100, 1).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " & Error.Description
End Sub
This code is not upto the mark still in WIP.
Your example data and requirements are difficult to understand.
I've modified your code a little, which may help you to progress.
If you can post a snippet of your data and the required result we can progress further
Sub GenerateInventory()
Dim r As Range, r1 As Range, rMS4Inventory As Range
Dim nLastRow As Long, i As Long
Dim wb As Workbook, sh As Worksheet, shMS4Inventory As Worksheet
On Error GoTo ErrHandler:
Set wb = ActiveWorkbook
Set sh = wb.ActiveSheet
Set shMS4Inventory = wb.Worksheets("MS4Inventory")
Set r = sh.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
Set r1 = sh.Cells(2, 8)
For i = 2 To nLastRow Step 1
If InStr(sh.Cells(i, 6), "CMRI") <> 0 Then
Set r1 = Union(r1, sh.Cells(i, 1))
End If
Next
Set rMS4Inventory = shMS4Inventory.Cells(100, 1).End(xlUp).Offset(1, 0).EntireRow
r1.EntireRow.Copy rMS4Inventory
Exit Sub
ErrHandler:
Resume
MsgBox Err.Number & ": " & Error.Description
End Sub
before going to the coding, let's grab the problem ....
you want to search for anything in the sheet, and return the three rows that belong to the "paragraph" where your search landed
Under the assumption that ALL paragraphs are TRIPLES, all the rows that mark the beginning of a "paragraph" have the same property: rownumber modulo 3 has the same constant value. So in whatever rownumber your search lands, you need to go back until rownumber modulo 3 gets equal your constant value. Having arrived there, you play out 3 rows - and stop
now coding should become pretty simple .... you fire a search or place the cursor "somewhere" by other means, and fire the Sub Grab()
Sub Grab3Rows()
Dim Idx As Long
Idx = Selection.Row
'find start of paragraph
Do While Idx Mod 3 <> 2 ' change this constant as per your sheet
Idx = Idx - 1
Loop
'select the 3 cells at the start of paragraph
Selection.Offset(Idx - Selection.Row, 0).Resize(3, 1).Select
'do the rest
End Sub
Under the assumption that paragraphs are n-tuples AND contain the string "Source" at the first line, you can do something similar: Whereever your search lands, you go back row by row until you arrive at a row containing string "Source", from there you play out rows until you again reach a row containing "Source"
Sub GrabByTextString()
Dim Idx As Long
Idx = Selection.Row
'find start of paragraph
Do While Left(Selection.Offset(Idx - Selection.Row, 0), 6) <> "Source"
Idx = Idx - 1
Loop
'select the the start of paragraph
Selection.Offset(Idx - Selection.Row, 0).Select
'expand selection until we reach next paragraph start
Idx = 1
Do While Left(Selection(1, 1).Offset(Idx, 0), 6) <> "Source"
Idx = Idx + 1
Selection.Resize(Idx, 1).Select
Loop
'do the rest
End Sub