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)
Related
I have data in column B that I need to loop through and then copy the corresponding value in column D for each row, to another sheet in the same workbook.
I need a code written to search through every value in Column B, return the corresponding value in Column D for the same row, and then find the next numbers in order from the given range(in this case I have set it from 7 to 10).
So loop through Column B, find values 7, 7a, 8, 9, 10 in that order (even if a larger value is located before a lower value as you go down), and copy the corresponding values in Column D to another sheet.
Excel Data Chart in Sheet3 (Column A is not needed):
A B C D E
1 1a 78.15 77.68 This is row 7
1a 2 77.18 76.92
2 3 76.92 76.63
3 4 76.13 75.78
4 4a 75.78 75.21
4a 5 75.11 74.87
5 5a 74.87 74.69
5a 6 73.94 73.6
6 6a 73.1 72.71
6a 6b 72.41 72.18
6b 10 72.18 71.6
10 11 71.3 70.89
11 12 70.89 69.83
12 13 69.83 68.68
13 14 68.68 67.68
14 15 67.63 66.46
15 16 66.01 64.84
16 16a 64.24 63.72
16a 16b 56.82 56.37
16b 16c 56.37 55.18
16c OUT 47.28 47.27
7 7a 83.12 76.07
7a 8 76.17 75.99
8 9 74.79 74.41
9 6 74.51 74 This is row 31
My problem: When the code encounters a cell containing letters AND numbers, it skips that cell and moves to the next cell in that range containing only numbers. How do I edit/re-write the code to INCLUDE alphanumeric values in the search criteria?
Here is my code that loops through column B but excludes cells with letters and numbers:
Sub EditBEST()
Dim Startval As Long
Dim Endval As Long 'Finds values corresponding
'to input in B and C
Dim LastRow As Long
LastRow = Sheets("Sheet3").range("B" & Rows.Count).End(xlUp).Row
Startval = Worksheets("Sheet3").Cells(1, "O").Value
Endval = Worksheets("Sheet3").Cells(1, "P").Value
StartRow = 2 'row that first value will be pasted in
For x = 7 To LastRow 'decides range to search thru in "Sheet3"
If Sheets("Sheet3").Cells(x, 2).Value >= 7 And Sheets("Sheet3").Cells(x, 2).Value <= 10 Then 'if cell is not blank
Sheets("Sheet4").Cells(StartRow, 2).Value = _
Sheets("Sheet3").Cells(x, 4).Value 'copy/select cell value in D
StartRow = StartRow + 1 'cell.Offset(0, 1).Value =
End If
If Sheets("Sheet3").Cells(x, 3) >= 7 And Sheets("Sheet3").Cells(x, 3).Offset(0, 1) <= 10 Then
Sheets("Sheet4").Cells(StartRow, 2).Value = _
Sheets("Sheet3").Cells(x, 5).Value
StartRow = StartRow + 1
End If
Next x
End Sub
Thank you
The main issue you are having is that you're conditional check filters out any string values. As # Grade 'Eh' Bacon pointed out, you need to provide some way to handle string values.
You also have some comments that are wrong or misleading.
For example, here, you have added the comment "if cell is not blank" but this is not what you are actually checking.
If Sheets("Sheet3").Cells(x, 2).Value >= 7 And Sheets("Sheet3").Cells(x, 2).Value <= 10 Then 'if cell is not blank
If you want to check if a cell is blank, you can check it's length. E.g.:
If Len(Sheets("Sheet3").Cells(x, 2).Value) > 0 Then
Now, that's really not entirely necessary for this procedure, but I just wanted to point it out since your comment indicates you were trying to do something different than your code was doing.
I haven't tested your code, but I wrote a function for pulling a single out of a string for you. This is all untested, so you may need to debug it, but should get your string problem sorted.
Sub EditBEST()
Dim Startval As Long
Dim Endval As Long 'Finds values corresponding
'to input in B and C
Dim StartOutputRow as Long
Dim LastRow As Long
Dim Val as Long
Dim Val2 as Long
LastRow = Sheets("Sheet3").range("B" & Rows.Count).End(xlUp).Row
Startval = Worksheets("Sheet3").Cells(1, "O").Value
Endval = Worksheets("Sheet3").Cells(1, "P").Value
StartOutputRow =2 'first row we will output to
OutputRow = StartOutputRow 'row of the cell to which matching values will be pasted
For x = 7 To LastRow
Val = GetSingleFromString(Sheets("Sheet3").Cells(x, 2).Value)
If Val >= 7 And Val <= 10 Then 'if value is within range
Sheets("Sheet4").Cells(OutputRow , 2).Value = _
Sheets("Sheet3").Cells(x, 4).Value 'copy cell value from D #the current row to column B #the output row
OutputRow = OutputRow + 1 'Next value will be on the next row
End If
Val = GetSingleFromString(Sheets("Sheet3").Cells(x, 3).Value)
Val2 = GetSingleFromString(Sheets("Sheet3").Cells(x, 3).Offset(0, 1).Value)
If Val >= 7 And Val2 <= 10 Then
Sheets("Sheet4").Cells(OutputRow , 2).Value = _
Sheets("Sheet3").Cells(x, 5).Value 'copy cell value from E #the current row to column B #the output row
OutputRow = OutputRow + 1
End If
Next x
'Sort the output:
Sheets("Sheet4").Range("B:B").Sort key1:=Range(.Cells(StartOutputRow,2), order1:=xlAscending, header:=xlNo
End Sub
Private Function GetSingleFromString(ByVal InString As String) As Single
If Len(InString) <= -1 Then
GetSingleFromString = -1
Exit Function
End If
Dim X As Long
Dim Temp1 As String
Dim Output As String
For X = 1 To Len(InString)
Temp1 = Mid(InString, X, 1)
If IsNumeric(Temp1) Or Temp1 = "." Then Output = Output & Temp1
Next
If Len(Output) > 0 Then
GetSingleFromString = CSng(Output)
Else
GetSingleFromString = -1
End If
End Function
I'm trying to figure out how to write a code where if given a set of data on Sheet1:
For example:
C
30 1234
31 0
32 0
33 56
34 789
(All these numbers range from 1-7 digits.)
I want to copy over the data onto Sheet2 like:
X Y Z Z AA AB AC AD
57 1 2 3 4
58 5 6
59 7 8 9
And this is just a simple example, I have a long list of data that sometimes contains the number 0, but I only want numbers greater than zero copied onto Sheet2.
So far, this is the code I've written so far:
Sub IfBlankNext()
Dim i As Integer
For i = 1 To 99
If Worksheets("Sheet1").Cells(i,1).Value <> 0 Then
{code code code}
End If
Next i
End Sub
For some reason, this code only returns the very last cell -- in this case, the cell data from Sheet1 Cell(99,3)
Before my code runs:
Sub IfBlankNext()
Dim i As Integer, x As Integer, LastRow As Long, DestLast As Long, HoldVal As String
'Define your last row of data by going to end and moving up:
LastRow = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow
If Sheets("Sheet1").Range("C" & i).Value > 0 Then
'Define the LastCol on your destination sheet using similar method as row:
DestLast = Sheets("Sheet2").Range("X" & Rows.Count).End(xlUp).Row + 1
If DestLast < 58 Then DestLast = 58
HoldVal = Sheets("Sheet1").Range("C" & i).Value
For x = 1 To Len(HoldVal)
Sheets("Sheet2").Cells(DestLast, x + 23).Value = Mid(HoldVal, x, 1)
Next x
End If
Next i
End Sub
After my code:
Code for changing cell alignment:
Sheets("Sheet2").Range("Name of Range").HorizontalAlignment = xlLeft OR xlRight
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.
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