I have two sheets in the same workbook. Sheet 2 is "DCT Accounts". Sheet 1 is "DCT".
If Column J in "DCT Accounts" says "Add Account", I want to append columns A, B, and C from "DCT Accounts" to the bottom of "DCT".
If Column K in "DCT Accounts" says "Close Account", I want to delete the entire row from "DCT".
I created the following lookup from "DCT Accounts" to "DCT". How do I append or delete rows based upon columns J & K?
=IFERROR(VLOOKUP('DCT Accounts'!A4,DCT!B:B,1,0),VLOOKUP('DCT Accounts'!B4,DCT!B:B,1,0))
Data in both sheets starts with row 4.
DCT
DCT Accounts
"DCT Accounts" is the same story, 700+ rows, but we're using column D as the lookup (which is a formula), but gives us the lookup we want.
You did not answer my clarification question...
So, please test the next code, designed exactly how you suggested. It should be very fast, using arrays and due to that, working in memory and deleting the rows at once:
Sub DeleteAddRow()
Dim wsDA As Worksheet, wsD As Worksheet, lastRDA As Long, lastRD As Long
Dim arrDA As Variant, rngDel As Range, arrD As Variant, arrCopy As Variant
Dim i As Long, j As Long, k As Long
Set wsDA = Worksheets("DCT Accounts")
Set wsD = Worksheets("DCT")
lastRDA = wsDA.Range("A" & rows.count).End(xlUp).row
lastRD = wsD.Range("A" & rows.count).End(xlUp).row
arrDA = wsDA.Range("A4:K" & lastRDA).Value 'place the range in an array
arrD = wsD.Range("A4:K" & lastRDA).Value 'place the range in an array
ReDim arrCopy(1 To 3, 1 To UBound(arrDA)) 'initially redim the array but transposed
'transposed to allow redim preserve to
'the last dimension
For i = 1 To UBound(arrDA)
If arrDA(i, 10) = "Add Account" Then
k = k + 1: arrCopy(1, k) = arrDA(i, 1): arrCopy(2, k) = arrDA(i, 2)
arrCopy(3, k) = arrDA(i, 3) 'fill the array with the data to be copied
End If
If arrDA(i, 11) = "Close Account" Then
For j = 1 To lastRD
If arrDA(i, 4) = arrD(j, 2) Then 'create the range to be deleted at once
If rngDel Is Nothing Then
Set rngDel = wsD.Range("A" & j + 3)
Else
Set rngDel = Union(rngDel, wsD.Range("A" & j + 3))
End If
Exit For
End If
Next j
End If
Next i
if k > 0 Then ReDim Preserve arrCopy(1 To 3, 1 To k) 'keep in the array only non empty elements
If Not rngDel is Nothing Then rngDel.EntireRow.Delete xlUp 'delete the range at once (very fast)
lastRD = wsD.Range("A" & rows.count).End(xlUp).row 'determine the last row after deletion
'drop the array values to the last empty row:
If k > 0 Then
wsD.Range("A" & lastRD + 1).Resize(k, 3).Value = _
WorksheetFunction.Transpose(arrCopy)
End If
End Sub
From procedural point of view, I think it would be good to clear "Add Account" from the sheet, after inputting the range in the array, or replacing it with something like "Account added". To do this, in order to avoid running the code twice for the same data and double the same account in "DCT".
But, firstly it would be good that you check the logic of determining the range to be copied (from D, or from B column...).
Related
I have a table with information in column A and an appropriate value in column B. I want to write a macro that inserts a new row for each "Person" in dependence of the value in column B and copies the original information into that row, which for example means that in the end there are 5 rows with "Person A", 2 rows for "Person B" etc.
original table:
result:
My first approach looks like that. It doesn't work.
Dim i, j, k As Integer
For i = Range("A" & Range("A:A").Rows.Count).End(xlUp).Row To 1 Step -1
For j = 1 To Range("B" & i)
Rows(i).Select
Selection.Insert Shift:=xlDown
k = k + j
Range(Cells(k, 1), Cells(k, 2)).Copy Destination:=Range("A" & i)
Next j
Next i
This would work for you, changing the number of inserts based on value in column B:
Option Explicit
Sub test()
With Sheets(1)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = lastRow To 1 Step -1
If IsNumeric(.Cells(i, 2).Value) = True Then
Dim numberOfInserts As Long
numberOfInserts = .Cells(i, 2).Value - 1
If numberOfInserts > 0 Then
Dim insertCount As Long
For insertCount = 1 To numberOfInserts
.Rows(i).Copy
.Rows(i).Insert
Next insertCount
End If
End If
Next i
End With
End Sub
First we check that you're dealing with numbers. Second you have a single line already, so number -1, then that this number is >0. Lastly, you insert via a loop which does the counting for you.
Test data:
Output after running:
Your index calculation is messed up. Use the debugger, step thru the code (F8) and notice what happens:
a) Your Select/Insert-construct creates a new row above the row you want to copy, not below.
b) Your calculation of index k fails: You are not initializing k, so it starts with value 0. Than you add j (1..3) to k, resulting in values 1, 3, 6, and copy data from that line.
I would suggest you take a different approach: Copy the original data into an array and then loop over that array. This avoids multiple Select, Copy and Insert statements (that are slow) and allow to copy the data from top to bottom.
Sub copy()
Dim rowCount As Long
Dim data As Variant
With ActiveSheet ' Replace with the sheet you want to work with
' Copy the current table into array
rowCount = .Cells(.Rows.Count, 1).End(xlUp).row
data = .Range(.Cells(1, 1), .Cells(rowCount, 2))
Dim oldRow As Long, newRow As Long
newRow = 1
' Loop over old data
For oldRow = 1 To rowCount
Dim repeatCount As Long
repeatCount = Val(data(oldRow, 2)) ' We want to have so many occurrences of the row
if repeatCount <= 0 Then repeatCount=1
Dim col As Long
' Create "repeatCount" rows of data (copy column by column)
For col = 1 To 2
.Cells(newRow, col).Resize(repeatCount, 1) = data(oldRow, col)
Next col
newRow = newRow + repeatCount
Next
End With
End Sub
Regarding this question “combine or merge cells with the same values vertically and horizontally” Link,
the provided answer (edited one) it works ,but with big range (e.g. 30 thousands rows) the macro takes a very long time to finish (no error raised but excel is not responding).
so, instead of putting only the first column on array,
Is it possible to move all the usedRange into array and processing all the tasks on memory and then copy back to the sheet?
I do not care about any lost format at all (fonts, rows height,..).
In advance, grateful for your helps.
Sub DeleteSimilarRows_AppendLastColuns()
Dim LastRow As Long, ws As Worksheet, arrWork, rngDel As Range, i As Long, j As Long, k As Long
Dim strVal As String, m As Long, boolNoFilter As Boolean
Set ws = ActiveSheet: LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
arrWork = ws.Range("A1:A" & LastRow).Value2 'Place the range in an array to make iteration faster
Application.DisplayAlerts = False: Application.ScreenUpdating = False
For i = 2 To UBound(arrWork) - 1 'Iterate between the array elements:
If arrWork(i, 1) = arrWork(i + 1, 1) Then
'Determine how many consecutive similar rows exist:__________________
For k = 1 To LastRow
If i + k + 1 >= UBound(arrWork) Then Exit For
If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
Next k '___________________________________________
For j = 14 To 14 'Build the concatenated string of cells in range "N":
strVal = ws.Cells(i, j).Value
For m = 1 To k
strVal = strVal & vbLf & ws.Cells(i + m, j).Value
Next m
ws.Cells(i, j).Value = strVal: strVal = ""
Next j
For m = 1 To k 'Place the cells for rows to be deleted in a Union range, to delete at the end, at once
If rngDel Is Nothing Then
Set rngDel = ws.Range("A" & i + m)
Else
Set rngDel = Union(rngDel, ws.Range("A" & i + m))
End If
Next m
i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'Increment the i variable and exiting if the resulted value exits the array size
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete 'Delete the not necessary rows
Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub
It is not only possible, but preferable. The speed increase is insane. This is how I do it:
Data from the spread sheet gets saved into a variable from type Variant -- the result is a 2-dimensional array (even if there is only one row/column in the range).
' Read data into Array
Dim data as Variant ' Important: has to be type Variant.
Set data = ActiveSheet.UsedRange.Value2 ' .Value or .Value2, as needed
When saving data back into the sheet, this code automatically selects a range of the appropriate size.
' Write array into cells
Dim target as Range
Set target = ActiveSheet.Cells(1,1) ' Start at A1 / R1C1; Change as appropriate
target.Resize(UBound(data, 1), UBound(data, 2)).Value = data
I need to display two columns A and B listed in a combobox with unique values. So if two rows have the same A but not the same B, it is not a duplicate, both column need to be duplicate. I found a code that list one column (A) with unique values but I don't know how to add the column B.
There's a picture of my data and how I want to display it in my ComboBox.
Here's the code:
Private Sub UserForm_Initialize()
Dim Cell As Range
Dim col As Variant
Dim Descending As Boolean
Dim Entries As Collection
Dim Items As Variant
Dim index As Long
Dim j As Long
Dim RngBeg As Range
Dim RngEnd As Range
Dim row As Long
Dim Sorted As Boolean
Dim temp As Variant
Dim test As Variant
Dim Wks As Worksheet
Set Wks = ThisWorkbook.Worksheets("Sheet1")
Set RngBeg = Wks.Range("A3")
col = RngBeg.Column
Set RngEnd = Wks.Cells(Rows.Count, col).End(xlUp)
Set Entries = New Collection
ReDim Items(0)
For row = RngBeg.row To RngEnd.row
Set Cell = Wks.Cells(row, col)
On Error Resume Next
test = Entries(Cell.Text)
If Err = 5 Then
Entries.Add index, Cell.Text
Items(index) = Cell.Text
index = index + 1
ReDim Preserve Items(index)
End If
On Error GoTo 0
Next row
index = index - 1
Descending = False
ReDim Preserve Items(index)
Do
Sorted = True
For j = 0 To index - 1
If Descending Xor StrComp(Items(j), Items(j + 1), vbTextCompare) = 1 Then
temp = Items(j + 1)
Items(j + 1) = Items(j)
Items(j) = temp
Sorted = False
End If
Next j
index = index - 1
Loop Until Sorted Or index < 1
ComboBox1.List = Items
End Sub
Any clue? Thanks!
Try this code, please. It assumes that unique definition means pairs of values from the two columns, on the same row, to be unique:
Sub UnicTwoValInTwoColumns()
Dim sh As Worksheet, arr As Variant, arrFin As Variant, countD As Long
Dim lastRow As Long, i As Long, j As Long, k As Long, boolDupl As Boolean
Set sh = ActiveSheet 'use here your sheet
'supposing that last row in column A:A is the same in column B:B
'If not, the last row for B:B will be calculated and then the higher will be chosen:
lastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
ReDim arrFin(1 To 2, 1 To lastRow) 'redim the final array for maximum possible number of elements
arr = sh.Range("A3:B" & lastRow).value 'pun in array the range to be analized
k = 1 'initialize the first array element number
For i = 1 To UBound(arr, 1) 'iterate between the array elements
boolDupl = False 'initialize the variable proving that the pair of data already in arrFin
For j = 1 To k 'iterate between the arrFin elements in order to check for duplicates
If arr(i, 1) & arr(i, 2) = arrFin(1, j) & arrFin(2, j) Then
boolDupl = True: Exit For 'if a duplicate is found the loop is exited
End If
Next j
If Not boolDupl Then 'load the arrFin only if a duplicate has not been found
arrFin(1, k) = arr(i, 1): arrFin(2, k) = arr(i, 2)
k = k + 1 'increment the (real) array number of elements
End If
Next
ReDim Preserve arrFin(1 To 2, 1 To k - 1) 'redim array at the real dimension (preserving values)
With Me.ComboBox1
.ColumnCount = 2 'be sure that combo has 2 columns to receive values
.List = WorksheetFunction.Transpose(arrFin) 'fill the combo with the array elements
End With
End Sub
You can paste the code in the form Initialize event, or let the Sub like it is, copy it in the form module and only call it from the event in discussion. I would suggest you to proceed in this las way. If you have (or will have) something else in the event, it would be simpler to identify a problem if it occurs, I think,
I have column A that has all existing categories, new categories are listed in column C. I'm trying to determine how to take these new categories, and add them to column "a" if they aren't already in column A. In the example the new categories in column C are added to column A even if there are already in column A. I would also need range("a1") in the if-then line to be a dynamic range since new categories will be added as the code runs. Some constructive criticism would be greatly appreciated as well to help me in the future.
Sub newcategory()
Dim newcatcount As Integer
Dim i As Integer
newcat = Range("c100000").End(xlUp).Row
For i = 1 To newcat
If Cells(i, 3).Value <> Range("a1") Then
Cells(i, 3).Select
Selection.copy
Range("a100000").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Please give this a try...
Sub AddNewCategories()
Dim lrA As Long, lrC As Long, i As Long, j As Long
Dim x, y, z(), dict
lrA = Cells(Rows.Count, 1).End(xlUp).Row
lrC = Cells(Rows.Count, 3).End(xlUp).Row
'Array to hold the categories in column A starting from Row1, assuming the categories start from A1. If not, change it accordingly.
x = Range("A1:A" & lrA).Value
'Array to hold the new categories in column C starting from Row1, assuming the categories start from C1. If not, change it accordingly.
y = Range("C1:C" & lrC).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = ""
Next i
For i = 1 To UBound(y, 1)
If Not dict.exists(y(i, 1)) Then
dict.Item(y(i, 1)) = ""
j = j + 1
ReDim Preserve z(1 To j)
z(j) = y(i, 1)
End If
Next i
If j > 0 Then
Range("A" & lrA + 1).Resize(j).Value = Application.Transpose(z)
End If
Set dict = Nothing
End Sub
you could use excel built in RemoveDuplicates() function, as follows (mind the comments):
Option Explicit
Sub newcategory()
Dim newcat As Range
With Worksheets("Categories") ' change "Categories" to your actual sheeet name
Set newcat = .Range("C1", .Cells(.Rows.Count, 3).End(xlUp)) ' get the range of all nwe categories in reference sheet column C from row 1 down to last not empty one
.Cells(.Rows.Count, 1).End(xlUp).Resize(newcat.Rows.Count).Value = newcat.Value ' append new categories values below existing categories in column A
.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).RemoveDuplicates Columns:=Array(1), Header:=xlNo ' remove duplicates
End With
End Sub
I have fours lists in Excel of arbitraty lenght.
A B C D
A1 B1 C1 D1
A2 B2 C2 D2
A3 B3 D3
A4 D4
D5
I want to create one table that has every combination from the lists as rows.
A B C D
A1 B1 C1 D1
A1 B1 C1 D2
...
A4 B3 C2 D5
Is there any simple way to do this in Excel - using Excel functionality, formulas or VBA?
If you have your four lists next to each other, highlight the data and insert a pivot table.
Add each of the columns to the "rows" section of the pivot table.
Right-click on each field in turn and click on "Field Settings".
Set the Layout and print to show tabular form, repeated item labels and items with no data as follows.
And this is the resulting table.
I suspect you'll want to delete the rows which contain 1 or more (blank) rows.
This is probably easiest by adding a formula to column E along the lines of
=IF(A2="(blank)",1,0)
Repeat this for the other columns, Add them up and sort by the total.
Delete all rows that have a non-zero entry.
Some nested for statements should handle this problem. Just put this in the VBA for your project and it will create a macro called CreateTable() which should put the table in a new worksheet for you.
Sub CreateTable()
'Creates a table will all combinations of values from four columns
Dim a, b, c, d As Range
'Activates sheet that has data on it to be copied to table
Worksheets("Sheet1").Activate 'Change Sheet1 to the name of your sheet
'Change A2 to first cell of data you want to be copied over
Set a = Range("A2", Range("A2").End(xlDown))
Set b = Range("B2", Range("B2").End(xlDown))
Set c = Range("C2", Range("C2").End(xlDown))
Set d = Range("D2", Range("D2").End(xlDown))
Dim i As Integer
i = 1 'Row number of the first row of data for the table of combinations
Worksheets("Sheet2").Activate 'Change Sheet2 to name of sheet you want the table to be put on
For Each cellA In a.Cells
For Each cellB In b.Cells
For Each cellC In c.Cells
For Each cellD In d.Cells
Worksheets("Sheet2").Cells(i, 1) = cellA.Value
Worksheets("Sheet2").Cells(i, 2) = cellB.Value
Worksheets("Sheet2").Cells(i, 3) = cellC.Value
Worksheets("Sheet2").Cells(i, 4) = cellD.Value
i = i + 1
Next cellD
Next cellC
Next cellB
Next cellA
End Sub
You should show what you've tried already and give specifics of where your data is coming from, but here's a VBA solution. Loops through each item in a given column, for as many rows as there are total combinations of items.
Sub Combination_Table()
Dim rList1 As Range
Dim rList2 As Range
Dim rList3 As Range
Dim rList4 As Range
Dim lLength1 As Long
Dim lLength2 As Long
Dim lLength3 As Long
Dim lLength4 As Long
Dim lRowcounter As Long
Sheets(1).Activate
With Sheets(1)
lLength1 = .Range("A" & .Rows.Count).End(xlUp).Row - 1
lLength2 = .Range("B" & .Rows.Count).End(xlUp).Row - 1
lLength3 = .Range("C" & .Rows.Count).End(xlUp).Row - 1
lLength4 = .Range("D" & .Rows.Count).End(xlUp).Row - 1
Set rList1 = .Range("A2:A" & lLength1)
Set rList2 = .Range("B2:B" & lLength2)
Set rList3 = .Range("C2:C" & lLength3)
Set rList4 = .Range("D2:D" & lLength4)
End With
'The above marks the ranges containing the original un-combined lists,
'with no duplicates and assuming row 1 is the header and all data is on
'columns A-D, without blanks.
rowcounter = 0
Sheets(2).Activate
For i = 1 To lLength1
For j = 1 To lLength2
For k = 1 To lLength3
For l = 1 To lLength4
rowcounter = rowcounter + 1
Sheets(2).Range("A" & rowcounter).Formula = rList1(i, 1).Text
Sheets(2).Range("B" & rowcounter).Formula = rList2(j, 1).Text
Sheets(2).Range("C" & rowcounter).Formula = rList3(k, 1).Text
Sheets(2).Range("D" & rowcounter).Formula = rList4(l, 1).Text
'This changes the text in columns A-D for the given rowcount, to the current
'iteration of the current looped value from the above lists
Next l
Next k
Next j
Next i
End Sub
This Works too and this is simpler.
Sub t()
Dim sht As Worksheet
Dim LastRow As Long, lastcol As Long
Dim i As Integer, j As Integer, k As Integer
Set sht = ThisWorkbook.Sheets("Sheet1")
LastRow = sht.Range("A1").CurrentRegion.Rows.Count
lastcol = sht.Range("A1").CurrentRegion.Columns.Count
k = 0
For i = 2 To LastRow
j = 1
k = k + 1
For j = 1 To lastcol
sht.Cells(i, j).Value = sht.Cells(1, j) & k
Next
Next
End Sub