Hello, I am doing a macro that copy the values on the columns, VALUES1, VALUES2, VALUES3 if it is not blank when the ARTICLE is the same.
I would have the first spreadsheet and I want the macro to return the second Spreadsheet.
I have managed how to make it:
Sub test()
Dim i, last, j, x As Integer
Dim R As Range
last = Sheets("List2").Range("A100000").End(xlUp).Row - 2
For i = 0 To last
Set R = Sheets("List2").Range("A2")
If Not WorksheetFunction.CountIf(Sheets("List2").Columns(1), _
Sheets("List2").Range("A2").Offset(i, 0).Value) = 0 Then
For j = 1 To WorksheetFunction.CountIf(Sheets("List2").Columns(1), _
Sheets("List2").Range("A2").Offset(i, 0).Value)
Set R = Sheets("List2").Columns(1).Find(Sheets("List2").Range("A2"). _
Offset(i, 0).Value, R, LookAt:=xlWhole)
For x = 0 To 2
If Not Sheets("List2").Range("B2").Offset(i, x).Value = "" Then
R.Offset(0, "1" + x).Value = Sheets("List2"). _
Range("B2").Offset(i, x).Value
End If
Next x
Next j
End If
Next i
End Sub
but the problem it takes too long, 'cause I have around 10.000 Rows and 20 Columns, and besides the Spreadsheet is not in order, so it could be to has a disorder, something like (A, B, B, A, ...)
Is there any way to make it faster o better???
Thanks a lot. Themolestones.
Here is a very easy solution with formulas to your problem:
Sheet2!A1=Sheet1!A1
Sheet2!B1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!B:B)
Sheet2!C1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!C:C)
Sheet2!D1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!D:D)
Put these formulas in the cells left of the = and copy down. You really need only the first two, because you can copy the second also to the right.
You need Sheet1 to be sorted by article.
That's it.
Of course, there might be occasions, when it is just necessary to implement this with VBA. Usually the fastest way to handle large amounts of cells with VBA, is to use array-copies of your ranges. Using worksheet-functions and looping through single cell references slows you down heavily.
Edit:
This would be my VBA solution
Public Sub Demo()
Dim arrRange() As Variant
Dim arrRangeResult() As Variant
Dim i As Long
Dim j As Long
Dim copyVal As Variant
Dim copyCond As Variant
Dim copyCol As Long
'create two copies of the origin data
arrRange = Range("A:D")
arrRangeResult = Range("A:D")
'loop through first data-copy, downwards through the articles
For i = LBound(arrRange, 1) + 1 To UBound(arrRange, 1)
'stop loop, if no article was found
If arrRange(i, 1) = "" Then Exit For
'store current article ID
copyCond = arrRange(i, 1)
'loop sideways through value-columns
For j = LBound(arrRange, 2) + 1 To UBound(arrRange, 2)
'store value & column, when found
If arrRange(i, j) <> "" Then
copyVal = arrRange(i, j)
copyCol = j
Exit For
End If
Next j
'loop through output array and paste value
For j = LBound(arrRangeResult, 1) + 1 To UBound(arrRangeResult, 1)
If arrRangeResult(j, 1) = copyCond Then
'paste-down found value to all occurences of article
arrRangeResult(j, copyCol) = copyVal
ElseIf arrRangeResult(j, 1) = "" Then
'early stop, when no article ID is found
Exit For
End If
Next j
Next i
'create output
Range("K:N") = arrRangeResult
End Sub
Related
I need to move a row's contents within Table1 (range A1:H24) to another Table2 (on a different sheet than Table1) based off the Table1's H-cell value.
Ex. If H24 = "Yes", paste entire row onto table2, delete from table 1.
The code deletes the data from Table1 and pastes it onto sheet2, but it pastes below the table getting lower with each time you run the module.
Sub Archive()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Inventory").UsedRange.Rows.Count
J = Worksheets("Archive").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Inventory").Range("H1:H" & J)
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Yes" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Yes" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
#medicinal_nut the code you mentioned is VERY similar to the code here.
You could have copied the code better by not replacing the I in the original code with the J in your code.
Set xRg = Worksheets("Inventory").Range("H1:H" & J)
IMHO, the code is doing what it is supposed to be doing because of the J=J+1.
It just inserts 1 new row below the last inserted row in your Archive sheet, otherwise, it would just overwrite the last-copied row with the newly copied row, which would be quite a waste, IMHO.
May be I don't understand your question, in which case, please state your question clearer. Or perhaps, you may be able to find a solution which might meet your needs, on the web page that I mentioned in the first line.
Edited 1 day later on 18JUL2021: to provide more understandable code for OP
Option Explicit
Sub Archive()
Dim HColumnRows As Range
Dim InventoryUsedRows As Long
Dim ArchiveUsedRows As Long
Dim HColumnCurrentRow As Long
InventoryUsedRows = Worksheets("Inventory").UsedRange.Rows.Count
'ArchiveUsedRows can be directly manipulated here to set pasting point
ArchiveUsedRows = Worksheets("Archive").UsedRange.Rows.Count
If ArchiveUsedRows = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then ArchiveUsedRows = 0
End If
Set HColumnRows = Worksheets("Inventory").Range("H1:H" & InventoryUsedRows)
On Error Resume Next
Application.ScreenUpdating = False
For HColumnCurrentRow = 1 To HColumnRows.Count
If CStr(HColumnRows(HColumnCurrentRow).Value) = "Yes" Then
'ArchiveUsedRows+n <- n can be changed to reset pasting point
HColumnRows(HColumnCurrentRow).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & ArchiveUsedRows + 1)
HColumnRows(HColumnCurrentRow).EntireRow.Delete
If CStr(HColumnRows(HColumnCurrentRow).Value) = "Yes" Then
HColumnCurrentRow = HColumnCurrentRow - 1
End If
'ArchiveUsedRows+n where n can be changed to reset pasting point
ArchiveUsedRows = ArchiveUsedRows + 1
End If
Next HColumnCurrentRow
Application.ScreenUpdating = True
End Sub
This code works almost perfectly. The problem is it includes blank cells in its "matched" results. What do I need to change to make this code ignore blank cells? Below I will include an example of what is going on.
Sub MarkMatches()
Const TopLeftCell As String = "A2" ' change to match where your data are
Dim Rng As Range ' data range
Dim FirstRow As Long, FirstClm As Long
Dim Data As Variant ' original data (2-D)
Dim Arr As Variant ' data rearranged (1-D)
Dim Tmp As Variant ' working variable
Dim R As Long, R1 As Long ' row counters
Dim C As Long ' column counter
Dim Count() As String ' match counter
With Range(TopLeftCell)
FirstRow = .Row
FirstClm = .Column
End With
C = Cells(FirstRow, Columns.Count).End(xlToLeft).Column
Set Rng = Range(Cells(FirstRow, FirstClm), _
Cells(Rows.Count, FirstClm).End(xlUp).Offset(0, C - FirstClm))
Data = Rng.Value
ReDim Arr(1 To UBound(Data))
For R = 1 To UBound(Data)
ReDim Tmp(1 To UBound(Data, 2))
For C = 1 To UBound(Data, 2)
Tmp(C) = Data(R, C)
Next C
Arr(R) = Tmp
Next R
ReDim Count(1 To UBound(Arr))
For R = 1 To UBound(Arr) - 1
For R1 = R + 1 To UBound(Arr)
Tmp = 0
For C = 1 To UBound(Arr(R))
If Not IsError(Application.Match(Arr(R)(C), Arr(R1), 0)) Then
Tmp = Tmp + 1
End If
Next C
If Tmp > 0 Then ' change to suit
Tmp = Format(Tmp, "(0)") & ", "
Count(R) = Count(R) & CStr(R1 + FirstRow - 1) & Tmp
Count(R1) = Count(R1) & CStr(R + FirstRow - 1) & Tmp
End If
Next R1
Next R
For R = 1 To UBound(Count)
If Len(Count(R)) Then Count(R) = Left(Count(R), Len(Count(R)) - 2)
Next R
' set the output column here (2 columns right of the last data column)
' to avoid including this column in the evaluation
' it must be blank before a re-run
Set Rng = Rng.Resize(, 1).Offset(0, UBound(Data, 2) + 1)
Rng.Value = Application.Transpose(Count)
End Sub
Thank you #Variatus for the code and help so far!
I tried to work with your original code, but honestly I became very confused. My example below will illustrate some practices that could help (and those who may review your code later, including yourself!). So here's a list of comments:
Always use Option Explicit. Your code may already have this, but I'm listing it here for completeness sake.
Create variable names that describe what data it holds. Your code does a little of this, but some of the variable names are difficult to fit into the logic flow. My idea in coding is always to try and write self-documenting code. That way, it's nearly always clear what the code is trying to accomplish. Then I'll use comment for code blocks where it might be a bit less clear. (Don't fall into the trap of prefixing variable names with a "type" or something; it's ultimately not worth it.)
A clear description of the problem always helps. This is true not only to get help on SO, but also for yourself. My final comment to your post above, asking about the problem description really simplified everything. This includes describing what you want your output to show.
As per the problem description, you need to identify each unique item and keep track of which row you find that item so you can create a report later. A Dictionary is a perfect tool for this. Read up about how to use a Dictionary, but you should be able to follow what this block of code is doing here (even without all the previous declarations):
For Each cell In dataArea.Cells
If Not IsEmpty(cell) Then
If items.Exists(cell.Value) Then
'--- add this row to the list
rowList = items(cell.Value) & "," & cell.Row
items(cell.Value) = rowList
Else
'--- first time adding this value
items.Add cell.Value, cell.Row
End If
End If
Next cell
It's easy to see how the logic of this code follows the description of the problem. After that, it's just a matter of running through each row in the data area and checking each value on that row to see if duplicates exist on any other row. The full example solution is below for you to study and adjust to fit your situation.
Option Explicit
Sub IdentifyMatches()
Dim ws As Worksheet
Set ws = Sheet1
Dim dataArea As Range
Set dataArea = ws.Range("A1:F6")
Dim items As Dictionary
Set items = New Dictionary
'--- build the data set of all unique items, and make a note
' of which row the item appears.
' KEY = cell value
' VALUE = CSV list of row numbers
Dim rowList As String
Dim cell As Range
For Each cell In dataArea.Cells
If Not IsEmpty(cell) Then
If items.Exists(cell.Value) Then
'--- add this row to the list
rowList = items(cell.Value) & "," & cell.Row
items(cell.Value) = rowList
Else
'--- first time adding this value
items.Add cell.Value, cell.Row
End If
End If
Next cell
'--- now work through the data, row by row and make the report
Dim report As String
Dim duplicateCount As Variant
ReDim duplicateCount(1 To dataArea.Rows.Count)
Dim dataRow As Range
For Each dataRow In dataArea.Rows
Erase duplicateCount
ReDim duplicateCount(1 To dataArea.Rows.Count)
Dim rowNumber As Variant
For Each cell In dataRow.Cells
If items.Exists(cell.Value) Then
rowList = items(cell.Value)
Dim rowNumbers As Variant
rowNumbers = Split(rowList, ",")
For Each rowNumber In rowNumbers
If rowNumber <> cell.Row Then
duplicateCount(rowNumber) = duplicateCount(rowNumber) + 1
End If
Next rowNumber
End If
Next cell
report = vbNullString
For rowNumber = 1 To UBound(duplicateCount)
If duplicateCount(rowNumber) > 0 Then
report = report & rowNumber & "(" & duplicateCount(rowNumber) & ")" & ", "
End If
Next rowNumber
'--- display the report in the next column at the end of the data area
If Len(report) > 0 Then
report = Left$(report, Len(report) - 2) 'removes the trailing comma and space
dataRow.Cells(1, dataRow.Columns.Count + 1).Value = report
End If
Next dataRow
End Sub
I have been stuck on this for weeks and have tried many formula combinations but can't get this to work. I don't know VBA so don't know where to start there.
I have List 1 and List 2 below. I need List 3 to be created from the data in Lists 1 and 2. List 3 can, preferably, be created in a new sheet.
I need to lookup the criteria from Column A, in List2 (Column D) then return all matches in a new list that shows: List 1; the criteria (Column A), data in Column B; and all matches from List 2 (Column E)
See Below. List 3 is the outcome
I broke this into two parts and I tried using a formula that copied the row the amount of times that there was a match. Then I was going to copy paste or find some vba or formula to combine the table but I came to a dead end when I realized the they tables weren't sorted in the same order. I ended up with these two lists to combine
Tried this VBA
Getting this error
Try This.
Run the macro "Test"
The first parameter should be the range of your first list (Just the numbers)
The second parameter should be the range of your second list (Just the numbers)
OutputSheet should be the sheet you want to output the list on
You can also optionally set the output row and output column (It will start at A1 if you don't specify)
Sub CreateList(List1 As Range, List2 As Range, OutputSheet As Worksheet, Optional ORow As Long = 1, Optional OCol As Long = 1)
Dim c, d
For Each c In List1
For Each d In List2
If c = d Then
OutputSheet.Cells(ORow, OCol).Value = c.Value
OutputSheet.Cells(ORow, OCol + 1).Value = c.Offset(0, 1).Value
OutputSheet.Cells(ORow, OCol + 2).Value = d.Offset(0, 1).Value
ORow = ORow + 1
End If
Next d
Next c
End Sub
Sub Test()
With Sheets("Sheet1")
CreateList .Range("A2:A7"), .Range("D2:D6"), Sheets("Sheet2")
End With
End Sub
The code loops through each number in the first list, and then each number in the second list.
If the numbers are the same, it outputs the number, the item, and the price.
First it will check If 10 = 10 Then - output the number, output the text next to the number on the first list, and output the amount next to the number on the second list.
Then it increases the row by 1.
That's pretty much all there is to it - just make sure you specify the ranges properly and change the sheet references as needed.
If you have never used VBA before, you can open the window by pressing ALT+F11
Right click to the left side and select Insert -> Module
Paste the code into the right side.
Update the ranges on the following line so they match where your lists are:
CreateList .Range("A2:A7"), .Range("D2:D6"), Sheets("Sheet2")
You can then close the window and press ALT+F8 to open the Run Macro dialog.
Select Test and click Run
Input:
Results:
What about this?
The code below assumes that on Sheet1, data starts from Row2 where Row1 is the header row.
Sub CreateList()
Dim x, y, z()
Dim i As Long, j As Long, k As Long, n As Long, dlr As Long
Dim wsData As Worksheet, wsOutput As Worksheet
Application.ScreenUpdating = False
Set wsData = Sheets("Sheet1")
On Error Resume Next
Set wsOutput = Sheets("List")
wsOutput.Cells.Clear
On Error GoTo 0
If wsOutput Is Nothing Then
Sheets.Add(after:=wsData).Name = "List"
Set wsOutput = ActiveSheet
End If
x = wsData.Range("A1").CurrentRegion.Value
y = wsData.Range("D1").CurrentRegion.Value
For i = 2 To UBound(x, 1)
If Application.CountIf(wsData.Columns("D"), x(i, 1)) > 0 Then
n = Application.CountIf(wsData.Columns("D"), x(i, 1))
ReDim z(1 To n)
k = 1
For j = 2 To UBound(y, 1)
If y(j, 1) = x(i, 1) Then
z(k) = y(j, 2)
k = k + 1
End If
Next j
dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
wsOutput.Range("A" & dlr).Value = x(i, 1)
wsOutput.Range("B" & dlr).Value = x(i, 2)
wsOutput.Range("C" & dlr).End(3)(2).Resize(UBound(z, 1), 1) = Application.Transpose(z)
End If
Erase z
Next i
dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
If dlr > 1 Then
wsOutput.Range("A2:C" & dlr).CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
wsOutput.Rows(1).Delete
End If
Application.ScreenUpdating = True
End Sub
I am writing a macro in excel for work and I am having trouble. In this scenario there are two sheets, "BU" and "TOPS Information". When the macro is used it is supposed to search every line of "BU" for the value found in "TOPS Information", then go to the next line of "TOPS Information and repeat the process. If it finds a correct match it is supposed to copy a cell and paste it into "TOPS Information".
Here is the code:
Sub QIM()
Dim j As Integer
Dim k As Integer
Dim i As Integer
Dim l As Integer
Dim m As Integer
Dim searchArray(1 To 3) As String
j = 0
k = 1
'WARNING: Temporary Sheet Names
lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row
lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row
'Cycle through BU rows
For j = lastRowTOPS To 1 Step -1
'Cycle through searchArray for each BU row
For k = lastRowBU To 1 Step -1
'//////////////////////////////////////
x = Sheets("BU").Range("B" & k).Value
y = Range("C" & j).Value
If StrComp(x, y) = 1 Then
Sheets("BU").Range("C" & k).Copy
Range("H" & j).PasteSpecial
End If
'//////////////////////////////////////
Next k
Next j
End Sub
This Macro obviously only works if "TOPS Information" is selected at the time. Any and all help would be most appreciated. THANKS!
You sorta answered it yourself. Range refers to the current sheet, but when you're bouncing around then you have to qualify it.
Prefix your ranges with the appropriate sheet like so,
Sub QIM()
Dim j As Integer
Dim k As Integer
Dim i As Integer
Dim l As Integer
Dim m As Integer
Dim searchArray(1 To 3) As String
j = 0
k = 1
'WARNING: Temporary Sheet Names
lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row
lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row
'Cycle through BU rows
For j = lastRowTOPS To 1 Step -1
'Cycle through searchArray for each BU row
For k = lastRowBU To 1 Step -1
'//////////////////////////////////////
x = Sheets("BU").Range("B" & k).Value
y = Sheets("TOPS Information").Range("C" & j).Value
If StrComp(x, y) = 1 Then
Sheets("BU").Range("C" & k).Copy
Sheets("TOPS Information").Range("H" & j).PasteSpecial
End If
'//////////////////////////////////////
Next k
Next j
End Sub
Assuming only want to copy the top most found data in BU to TOPS, you can use below.
Sub QIM()
Dim oWS_TOPS As Worksheet, oWS_BU As Worksheet ' Worksheet objects
Dim oRng_TOPS As Range, oRng_BU As Range ' Range objects
Dim R_TOPS As Long, R_BU As Long
Set oWS_TOPS = ThisWorkbook.Worksheets("TOPS Information") ' <-- Replace this "TOPS Information" to match future changes
Set oWS_BU = ThisWorkbook.Worksheets("BU") ' <-- Replace this "BU" to match future changes
R_TOPS = oWS_TOPS.Cells(Rows.Count, "A").End(xlUp).Row
R_BU = oWS_BU.Cells(Rows.Count, "A").End(xlUp).Row
' Search column B of BU for each cell in column C of TOPS
For Each oRng_TOPS In oWS_TOPS.Columns("C").Cells ' <-- Replace this "C" to match future changes
' Exit if row is more than last A column data
If oRng_TOPS.Row > R_TOPS Then Exit For
For Each oRng_BU In oWS_BU.Columns("B").Cells ' <-- Replace this "B" to match future changes
' Exit if row is more than last A column data
If oRng_BU.Row > R_BU Then Exit For
' Check if Ranges match (## See Update ##)
If InStr(1, oRng_TOPS.Value, oRng_BU.Value, vbTextCompare) > 0 Then
' Copy column C of found row in BU to column H of TOPS, then exit
oWS_BU.Cells(oRng_BU.Row, "C").Copy oWS_TOPS.Cells(oRng_TOPS.Row, "H") ' <-- Replace these "C" and "H" to match future changes
Exit For
End If
Next
Next
Set oWS_TOPS = Nothing
Set oWS_BU = Nothing
End Sub
There are many ways to achieve your goal, and this is one of it.
UPDATE Note on comparing cell values (String):
StrComp(S1,S2[,mode]) only return 3 values {-1, 0, 1} to indicate if S1 is less/equal/greater than S2. If you want an exact match (case sensitive and exact spacing), use If StrComp(S1,S2) = 0 Then.
InStr([i,]S1,S2[,mode]) only returns positive values - it returns the character location of first appearance of S2 in S1. If S2 is not found then it returns zero.
You can also use Trim(sText) to remove leading/ending spaces of sText.
Hope below screenshot says more.
Assume Column B has data such as Data1/Data2/Data3-1/Data3-7 - all other rows have various data.
I need to take each row that has that Column B (some may not) and create 1 row for each individual value, with every other piece of data in the row copied for all of them.
Data may have symbols, dashes, and other random stuff, but the actual data itself will not have a / in it, only / is used to designate split lines
Any1 know the best way to do this? Excel 07 and OO available.
Is a VBA solution OK?
Sub DuplicateRows()
Dim r As Range
Set r = Cells(Rows.Count, 2).End(xlUp)
Do While r.Row > 1
TestRow r
Set r = r.Offset(-1, 0)
Loop
TestRow r
End Sub
Sub TestRow(r As Range)
Dim i As Long, n As Long
Dim a() As String
i = InStr(r, "/")
If i > 0 Then
n = Len(r) - Len(Replace(r, "/", ""))
r.EntireRow.Copy
r.Offset(1, 0).Resize(n).EntireRow.Insert Shift:=xlDown
a = Split(r, "/")
For i = 0 To n
r.Offset(i, 0) = a(i)
Next
End If
Application.CutCopyMode = False
End Sub