I am trying to write a macro using VBA in excel to copy the rows based on column A that does not appear in column B, to a new sheet. For example, on the following table, only copy the rows with column A that is 3,4, 5, and 6 to a new sheet. Any help is greatly appreciated.
The table looks like below.
Column A ColumnB
1 1
1 2
1 7
2 -
2 -
3 -
3 -
4 -
5 -
5 -
6 -
7 -
Sub sorter()
Dim find1 As Object, find2 As Object
Dim row1 As Integer, row2 As Integer
Dim myWB As Workbook
Set myWB = ThisWorkbook
row1 = 1
row2 = 1
Do
Set find1 = myWB.Sheets(1).Range("B:B").Find(What:=myWB.Sheets(1).Cells(row1, 1).Value, LookIn:=xlValues)
If find1 Is Nothing Then
Set find2 = myWB.Sheets(2).Range("A:A").Find(What:=myWB.Sheets(1).Cells(row1, 1).Value, LookIn:=xlValues)
If find2 Is Nothing Then
myWB.Sheets(2).Cells(row2, 1).Value = myWB.Sheets(1).Cells(row1, 1).Value
row2 = row2 + 1
End If
End If
row1 = row1 + 1
Loop Until myWB.Sheets(1).Cells(row1, 1).Value = ""
End Sub
just make sure you dont put blanks in first column :)
Related
I have data in column A with 50000 rows of data. I need to transpose every 6 rows of data to 6 columns. For example data from A1:A6 must be transposed to B1:G1. Again data from A7:A14 must be transposed to B2:G2. I appreciate if anyone can provide VBA code for this.
Data I have in column A is as shown below:
Col A
1
2
3
4
5
6
7
8
9
10
11
12
The transpose data must be as shown below in col B to col G:
Columns B C D E F G
1 2 3 4 5 6
7 8 9 10 11 12
Try this:
Sub TransposeRows()
Dim rng As Range
Dim i As Long
Set rng = Range("A1")
While rng.Value <> ""
i = i + 1
rng.Resize(6).Copy
Range("B" & i).PasteSpecial Transpose:=True
Set rng = rng.Offset(6)
Wend
Application.CutCopyMode = False
End Sub
Got this from here.
additional variant from my side:
Sub TransposeRows2()
Dim i&, z&, x&
i = Cells(Rows.Count, "A").End(xlUp).Row
z = 1: x = 1
While z <= i
Range("B" & x).Resize(, 6) = _
WorksheetFunction.Transpose(Range("A" & z).Resize(6))
z = z + 6: x = x + 1
Wend
End Sub
tested:
You do not need a macro for this. In B1 enter:
=OFFSET($A$1,COLUMNS($A:A)-1+(ROWS($1:1)-1)*6,0)
Then copy both across and down:
In Portuguese Excel, "Gary's Student"'s formula, for 4 columns instead of 6, becomes:
=DESLOCAMENTO($A$1;COLS($A:A)-1+(LINS($1:1)-1)*4;0)
So I have something like this:
A B C ...
1 11 12 13
2 10 20 15
3 1 -8 -2
...
So A3, B3, and C3 is generated by subtracting A1 to A2 and so on.
If you look at the top of the sheet there is a long formula bar that shows the formula of a cell when you click on one. If you are filling in the sheet manually, you can type in that bar something like = A1 - A2 and it will fill A3 for you.
In my case, I am using .Formula = "IFERROR(A1 - A2, ""N/A""") in my code.
The problem I am having is that when the sheet is generated, instead of the desired output shown above, it is displaying something like this
A B C ...
1 11 12 13
2 10 20 15
3 #NAME? #NAME? #NAME?
...
If I click on the cell, the formula bar actually shows that it is apply the correct formula, and if I hit Enter after clicking on the formula bar, the correct numbers show up. So it's like I'm manually entering the formula.
This is my code. ConvertToLetter() takes in an integer and convert to column character.
Public Function ProcessExcelRpt(dataArray(,) As Object) As Integer
Dim ws As Worksheet
Dim r As Range
Try
For i As Integer = 1 To xlWorkBook.Sheets.Count
ws = xlWorkBook.Sheets(i)
r = ws.Range("A8")
ws.Range("A8").Resize(dataArray.GetUpperBound(0) + 1, dataArray.GetUpperBound(1) + 1).Value2 = dataArray
ws.Range("A2").Value2 = ws.Range("A2").Value2.ToString() & FormatDate(ReportDate, "MMMM dd, yyyy")
FormatColumns(ws, 8, dataArray.GetUpperBound(0) + 8)
excel.CalculateFull()
xlWorkBook.SaveAs(saveAs)
Exit For
Next
Catch ex As Exception
Return -1
End Try
Return 0
End Function
Public Sub FormatColumns(ws As Worksheet, ByVal firstRow As Integer, ByVal lastRow As Integer)
Dim rng As Range
Try
Dim colCnt, rowCnt, i As Integer
i = 0
For rowCnt = firstRow To lastRow
Dim row1, row2 As Integer
row1 = rowCnt - 2 ' go back 2 rows
row2 = rowCnt - 1 ' go back 1 row
' Apply formula to each cell in each row
For colCnt = 1 To 3
rng = ws.Range(ConvertToLetter(colCnt) & rowCnt) ' A1 for ex
rng.Formula = "=IFERROR(" & ConvertToLetter(colCnt) & row1 & "-" & ConvertToLetter(colCnt) & row2 & ", ""N/A"")"
Next
Next
Catch ex As Exception
End Try
End Sub
If you run this as a Sub it is working for me:
Sub foo(firstRow, lastRow)
Dim rng As Range
For rowCnt = firstRow To lastRow
Dim row1, row2 As Integer
row1 = rowCnt - 2 ' go back 2 rows
row2 = rowCnt - 1 ' go back 1 row
' Apply formula to each cell in each row
For colCnt = 1 To 3
Set rng = Cells(rowCnt, colCnt) ' A1 for ex
rng.Formula = "=IFERROR(" & Cells(row1, colCnt).Address & "-" & Cells(row2, colCnt).Address & ", ""N/A"")"
Next
Next
End Sub
If you are trying to execute this from a Function call as a UDF, it will not work because of explicit limitations on what UDFs can manipulate on the worksheet, specifically that you cannot:
Change another cell's value.
https://support.microsoft.com/en-us/kb/170787
I think what I'm trying to do is pretty basic, but I'm brand new to VBA so I'm getting stuck and the answers I've found are close, but not quite right.
I have a list of row entries, like this:
1 4 32 2 4
2 6 33 1 3
1 4 32 2 4
4 2 30 1 5
Notice that rows 1 and 3 are duplicates. I'd like to only have a single instance of each unique row but I don't want to just delete the duplicates, I want to report how many of each type there are. Each row represents an inventory item, so deleting duplicate entries without indicating total quantity would be very bad!
So, my desired output would look something like this, where the additional 6th column counts the total number of instances of each item:
1 4 32 2 4 2
2 6 33 1 3 1
4 2 30 1 5 1
My data sets are larger than just these 5 columns, they're closer to 10 or so, so I'd like to put that last column at the end, rather than to hardcode it to the 6th column (i.e., column "F")
Update:
I found some code that worked with minor tweaking, and it worked this morning, but after messing around with some other macros, when I came back to this one it was telling me that I have a "compile error, wrong number of arguments or invalid property assignment" and it seemed to be unhappy with the "range". Why would working code stop working?
Sub mcrCombineAndScrubDups2()
For Each a In range("A1", Cells(Rows.Count, "A").End(xlUp))
For r = 1 To Cells(Rows.Count, "A").End(xlUp).Row - a.Row
If a = a.Offset(r, 0) And a.Offset(0, 1) = a.Offset(r, 1) And a.Offset(0, 2) = a.Offset(r, 2) Then
a.Offset(0, 4) = a.Offset(0, 4) + a.Offset(r, 4)
a.Offset(r, 0).EntireRow.Delete
r = r - 1
End If
Next r
Next a
End Sub
Assuming that your data starts from A1 on a worksheet named ws1, the following code removes the duplicated rows. Not by shifting the whole table but deleting the entire row.
Sub deletedupe()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim row1 As String
Dim row2 As String
i = 1
j = 1
k = 1
Do While Sheets("ws1").Cells(i, 1).Value <> ""
row1 = ""
j = 1
Do While Sheets("ws1").Cells(i, j).Value <> ""
row1 = row1 & Sheets("ws1").Cells(i, j).Value & " "
j = j + 1
Loop
k = i + 1
Do While Sheets("ws1").Cells(k, 1).Value <> ""
row2 = ""
j = 1
Do While Sheets("ws1").Cells(k, j).Value <> ""
row2 = row2 & Sheets("ws1").Cells(k, j).Value & " "
j = j + 1
Loop
If row1 = row2 Then
Sheets("ws1").Rows(k).EntireRow.Delete
Else
k = k + 1
End If
Loop
i = i + 1
Loop
End Sub
Using office 2010. everything is in same sheet.
Data in Column A B C & D can change (increase or decrease daily)
I have 4 column
OUTPUT --> IN column F should be
---A-----B-----C------D---------------------------------------F
1 5 8 AP 1
2 6 9 BP 2
3 7 1 CD 3
4 5 QW 4
5
6
7
8
9
1
5
AP
BP
CD
QW
length of columns A B C & D can increase of decrease.
How about this?
Sub move()
Dim ws As Worksheet
Dim outputColumn As Long
Dim currentColumn As Long
Dim currentOutputRow As Long
Set ws = ActiveSheet
outputColumn = 6 ' column f
For currentColumn = 1 To 4
currentOutputRow = ws.Cells(ws.Rows.Count, outputColumn).End(xlUp).Row
If (currentOutputRow > 1) Then
currentOutputRow = currentOutputRow + 1
End If
ws.Range(ws.Cells(1, currentColumn), ws.Cells(ws.Rows.Count, currentColumn).End(xlUp)).Copy _
ws.Cells(currentOutputRow, outputColumn)
Next
End Sub
use the below. It accepts the range you need to change and will return a vertical array of values. To fill the values use an array formula.
Function ToVector(rng As Range)
Dim cells()
ReDim cells(rng.cells.Count)
Dim i As Double
For Each cell In rng
cells(i) = cell
i = i + 1
Next cell
ToVector = Application.WorksheetFunction.Transpose(cells)
End Function
With the help of this site get-digital-help.com/
Combine Columns But this is only static.
I converted it to dynamic meaning changing range.
for example I posted A B C D IN F
To make formula more clear will enter formula in Name Manager
BELOW IS DYNAMIC FORMULA FOR EACH COLUMN (goes in name manger)
ALIST = =OFFSET($A$1,0,0,COUNTA($A:$A),1)
BLIST = =OFFSET($B$1,0,0,COUNTA($B:$B),1)
CLIST = =OFFSET($C$1,0,0,COUNTA($C:$C),1)
DLIST = =OFFSET($D$1,0,0,COUNTA($D:$D),1)
FORMULA IN COLUMN F and drag down
=IFERROR(INDEX(ALIST, ROWS(F$1:$F1)),
IFERROR(INDEX(BLIST, ROWS(F$1:$F1)-ROWS(ALIST)),
IFERROR(INDEX(CLIST, ROWS(F$1:$F1)-ROWS(ALIST)-ROWS(BLIST)),
IFERROR(INDEX(DLIST, ROWS(F$1:$F1)-ROWS(ALIST)-ROWS(BLIST)-ROWS(CLIST)),""))))
Screenshot
I have an excel sheet with the following data:
col1 col2 col3 col4
dvdtable 6 52 57
tvunit 2 30 31
I need to copy each row in another sheet, however making 6 copies of the dvdtable row and 2 copies of the tvunit row. (col2 is referring to the quantity). In addition I need to create a new column where for each of the 6 dvdtable rows I include 52,53,54,55,56,57 respectively in the new column. See the result below:
col1 col2 col3
dvdtable 6 52
dvdtable 6 53
dvdtable 6 54
dvdtable 6 55
dvdtable 6 56
dvdtable 6 57
tvunit 2 30
tvunit 2 31
I managed to produce the code that makes multiple copies of rows thanks to another question in your forum, but I am stuck with the last part of the programming, where I need to create the list of numbers within the range given in column 3 and column 4 for each type of furniture.
You likely have to change the sheetnames.
Option Explicit
Sub whyDidIDoThisForYou()
Dim i, j, k As Integer
Dim numbRows As Integer
Dim curWriteRow As Integer
Dim temp As Integer
Dim values() As String
numbRows = Range("a1").End(xlDown).Row - 1 'assumes heading
curWriteRow = 1
ReDim values(1 To numbRows, 1 To 4)
For i = 1 To numbRows
'read all values in from initial datasheet
For j = 1 To 4
values(numbRows, j) = Sheets("Sheet1").Cells(i + 1, j).Value
Next j
'write to next sheet
'get number of things to write
temp = values(numbRows, 4) - values(numbRows, 3)
'start writing the "output" sheet!
For j = 0 To temp
Sheets("Sheet2").Cells(curWriteRow, 1).Value = values(numbRows, 1)
Sheets("Sheet2").Cells(curWriteRow, 2).Value = values(numbRows, 2)
Sheets("Sheet2").Cells(curWriteRow, 3).Value = values(numbRows, 3) + j
curWriteRow = curWriteRow + 1
Next j
Next i
End Sub
You could use arrays as below which is much quicker than writing to ranges cell by cell
The code below
reads the orginal data into a variant array Y
loops through each row of Y (lngCnt2)
runs through that Y by the number of times specifiec in colulmB (lngCnt3)
dumps the new records to a second variant array X
dumps x to a range starting in E1 when finished
Sub SplicenDice()
Dim rng1 As Range
Dim lngCnt As Long
Dim lngCnt2 As Long
Dim lngCnt3 As Long
Dim lngCnt4 As Long
Dim X
Dim Y
Set rng1 = Range([a1], Cells(Rows.Count, "D").End(xlUp))
Y = rng1.Value2
lngCnt = Application.WorksheetFunction.Sum(Range("B:B"))
ReDim X(1 To lngCnt, 1 To 3)
For lngCnt2 = 1 To UBound(Y, 1)
For lngCnt3 = 1 To Y(lngCnt2, 2)
lngCnt4 = lngCnt4 + 1
X(lngCnt4, 1) = Y(lngCnt2, 1)
X(lngCnt4, 2) = Y(lngCnt2, 2)
X(lngCnt4, 3) = Y(lngCnt2, 3) + lngCnt3 - 1
Next
Next
[e1].Resize(UBound(X, 1), UBound(X, 2)).Value2 = X
End Sub