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
Related
I have a spreadsheet with data as follows:
G H I J K L M N O P Q R S T U V W X Y Z AA AB AC AD ... etc.
2 1
3 2
4 4 8 12 16 20 24 28 32 36 40
5 8 16 24 32 40
That is, G2 = 1, G3 = 1 ... M4 = 28 and so on...
What I need help with is going through this range, which can be dynamic as people are entering data into this range when they need to change stuff. I need to iterate through the rows and then columns and, for each cell that has a value, I need to paste it into a different sheet in column D, 9 times for each cell.
That is, on the 2nd sheet, the data above would come across as:
Column
D
1
1
1
1
1
1
1
1
1
2
2
2
2
2
2
2
2
2
4
4
.. etc...
How do I iterate through each row, and then each column and then for each cell that has a value, copy that 9 times into column D on another sheet, and then for the next cell with a value, copy that BELOW what was pasted and so on?
Try the following. It assumes you want to go column by column iterating through all the populated cells in that column, repeating the value 9 times.
Option Explicit
Public Sub OutputRepeatedValues()
Dim arr()
Const DELIMITER As String = ","
Const NUMOFTIMES As Long = 9
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range(.Range("G2"), .Range("G2").SpecialCells(xlLastCell)).Value
End With
Dim i As Long, j As Long, output As String
For i = LBound(arr, 2) To UBound(arr, 2) '<== iterate rows with a column, column by column
For j = LBound(arr, 1) To UBound(arr, 1)
If Not IsEmpty(arr(j, i)) Then output = output & Replicate(arr(j, i), NUMOFTIMES, DELIMITER)
Next j
Next i
output = Left$(output, Len(output) - 1)
ThisWorkbook.Worksheets("Sheet2").Range("B1").Resize(Len(output), 1) = Application.WorksheetFunction.Transpose(Split(output, DELIMITER))
End Sub
'Adapted from #this https://codereview.stackexchange.com/questions/159080/string-repeat-function-in-vba?utm_medium=organic&utm_source=google_rich_qa&utm_campaign=google_rich_qa
Public Function Replicate(ByVal RepeatString As String, ByVal NUMOFTIMES As Long, Optional ByVal DELIMITER As String = ",")
Dim s As String, c As Long, l As Long, i As Long
l = Len(RepeatString) + 1
c = l * NUMOFTIMES
s = Space$(c)
For i = 1 To c Step l
Mid(s, i, l) = RepeatString & DELIMITER
Next i
Replicate = s
End Function
Notes:
Test dataset laid out as shown below
I assume that you want to work with what ever data is down or the right of G2, including G2. In order to do this I am using SpecialCells(xlLastCell) to find the last used cell. I then construct a range with .Range(.Range("G2"), .Range("G2").SpecialCells(xlLastCell)), which in this case is $G$2:$Q$5, and read that into an array.
Assume that you indeed iterate rows with a column before moving onto next column as described in your question. I concatenate the populated cells values whilst at the same time calling the Replicate function described in 4).
I have hijacked, and adapted, a performant function by #this, to handle the string repeat. I have added in an optional argument for delimiter. A delimiter is added so I can later split on this to write out the results to individual cells within the target worksheet.
I split the string, output, on the delimiter, this creates an array of the repeated values, which I transpose, so I can write out to a column in the target sheet.
Example output:
Edit:
If instead you want to loop the rows, then columns, use with the above function the following instead:
Public Sub OutputRepeatedValues()
Dim arr()
Const DELIMITER As String = ","
Const NUMOFTIMES As Long = 9
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range(.Range("G2"), .Range("G2").SpecialCells(xlLastCell)).Value
End With
Dim i As Long, j As Long, output As String
For i = LBound(arr, 1) To UBound(arr, 1) '<== iterate rows with a column, column by column
For j = LBound(arr, 2) To UBound(arr, 2)
If Not IsEmpty(arr(i, j)) Then output = output & Replicate(arr(i, j), NUMOFTIMES, DELIMITER)
Next j
Next i
output = Left$(output, Len(output) - 1)
ThisWorkbook.Worksheets("Sheet2").Range("B1").Resize(Len(output), 1) = Application.WorksheetFunction.Transpose(Split(output, DELIMITER))
End Sub
My vba is rusty but I think this (pseudo) code might help you.
def last_row as integer, last_col as integer, row as integer, col as integer, target as integer
'I like something like this to get the value but you have to know the largest column: Cells(Rows.Count, col_to_check).End(xlUp).Row
target = 1
for col = 7 to last_col '7 = G
for row = 2 to last_row
if(Not IsEmpty(Cells(row,col)) then
Range(Cells(target*9-8, 4), Cells(target*9, 4))= Cells(row,col)
target = target +1
end
next row
next col
this iterates through all cols and rows checks if there is a value and the copies it to a 9-cell range then iterates the target so it will point to the next 9 cells.
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)
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 :)
In Excel I have a the following set up in Sheet 1
A B C D E
1 a 12 123
2 b 234 2342
3 c 12 23 54 342
4 d 234 33 54
5 e 234 34 66
6 f 345
and the table below in Sheet 2
A B
1 b 2
2 d 3
3 e 1
Sheet 2 determines if some extra rows should be added to Sheet 1 or not, and if not, the row should be deleted.
Giving the result below in Sheet 1
A B C D
1 b 234 2342
2
3
4 d 234 33 54
5
6
7
8 e 234 34 66
9
Note that b,d & e were the only rows remaining from the original data and also the number of rows added below that row relate to the number in column B in sheet 2 for each remaining row.
I would like to use VBA to carry this out. I have read that deleting rows based on criteria means you need to go through a loop from the bottom row to the top row, but I am struggling to make it work for my example.
Here is the code I have used so far but it doesn't seem to work:
Sub maketab()
Range("A1").Select
Dim r As Long
lr = Range("A1").Row
hr = Range("A1").Offset(8 - 1).Row
For r = hr To lr Step -1
Dim given_rng As Range
Set given_rng = Sheet2.Range("A1")
Dim p As Long
lr_small = given_rng.Row
hr_small = given_rng.End(xlDown).Row
For p = hr_small To lr_small Step -1
If Range("A" & r).Value = Range("A" & p).Value Then
'Add a row below
Range("A" & r).Offset(1).Select
Selection.Resize(Sheet2.Range("A" & p).Offset(0, 1).Value).EntireRow.Insert
Range("A" & r).Select
Else
'Delete a row
Rows(r & ":" & r).Select
Selection.Delete Shift:=xlUp
End If
Next p
Next r
End Sub
As always any help would be greatly appreciated
Try this:
Sub test()
Dim xlws1 As Worksheet
Dim xlws2 As Worksheet
Dim xlws3 As Worksheet
Dim i As Integer
Dim j As Integer
Dim k As Integer
'setting sheet variables
Set xlws1 = Worksheets("Sheet1")
Set xlws2 = Worksheets("Sheet2")
Set xlws3 = Worksheets("Sheet3")
k = 1 'setting initial value of k
i = 1 'setting initial value of i
Do While IsEmpty(xlws1.Range("A" & i)) = False
j = 1 'resetting j
Do While IsEmpty(xlws2.Range("A" & j)) = False 'setting loop up
If xlws1.Range("A" & i).Value = xlws2.Range("A" & j).Value Then 'if value matches current sheet 1 value
xlws1.Rows(i).Copy ' copy row
xlws3.Range("A" & k).PasteSpecial xlPasteAll 'paste row
k = k + 1 'increment k
Exit Do ' move on
End If
j = j + 1 'increment j
Loop
i = i + 1 'increment i
Loop
End Sub
I am trying to compare two sheets within one workbook. I need to match values in column A of the first sheet with column A of sheet 2 and, if a matching value is found, copy and paste a value from column E of sheet 2 into column E of sheet 1. For example:
Sheet 1: A B C D E Sheet 2: A B C D E
k 9 b 3 k d 3 d 6
j 2 d 4 m h 4 g 3
s 3 u 9 j e 8 a 9
i 4 s 6 s i 9 t 7
o 7 n 8 l b 10 s 9
i c 4 p 8
o l 0 n 9
Would become
Sheet 1: A B C D E
k 9 b 3 6
j 2 d 4 9
s 3 u 9 7
i 4 s 6 8
o 7 n 8 9
The code I am currently working with is:
Sub mergeCategoryValues()
Dim lngRow As Long
With ActiveSheet
lngRow = .Cells(65536, 1).End(xlUp).Row
.Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes
Do
If .Cells(lngRow, 1) = Sheets("Sheet2").Cells(lngRow, 1) Then
.Cells(lngRow, 5) = Sheets("Sheet2").Cells(lngRow, 5)
End If
lngRow = lngRow - 1
Loop Until lngRow < 2
End With
End Sub
I need to pull duplicates regardless of case. Is this possible?
Any help is appreciated.
Thank you in advance.
I've worked out a VBA code:
Sub sof20355637MergeCategoryValues()
Dim i As Long, i2 As Long, lngRow As Long, lngRow2 As Long
Dim strKey As String
Dim wks1, wks2 As Worksheet
Dim objRange2
Set wks1 = Sheets("Sheet1")
Set wks2 = Sheets("Sheet2")
' get mximum rows of each sheet:
lngRow = wks1.Cells(wks1.Rows.Count, 1).End(xlUp).Row
lngRow2 = wks2.Cells(wks1.Rows.Count, 1).End(xlUp).Row
' we loop on the first column of sheet1:
For i = 1 To lngRow
strKey = wks1.Range("A" & i)
Set objRange2 = wks2.Range("A:A").Find(strKey, Range("A1"), SearchDirection:=xlPrevious)
If (Not objRange2 Is Nothing) Then
i2 = objRange2.Row
wks1.Range("E" & i) = wks2.Range("E" & i2)
End If
Next
Set objRange2 = Nothing
Set wks1 = Nothing
Set wks2 = Nothing
End Sub
With some images:
Sheet1: Sheet2:
Merged Sheet1:
Assuming k on Sheet 1 is in A1, then in E1 of Sheet 1:
=VLOOKUP(A1,'Sheet 2'!A:E,5,0)
and copied down to suit may serve, though not VBA.