I was wondering it is possible to transpose a specific number of columns in a single column and display it in a row. For example, if there was a column that extended from A1 to A1000000, is it is possible to select the first 272 data points and then transpose it into a single row starting at A1 and then select the next 272 rows and display it on B1 etc. until it reaches the last row.
Thanks,
Select A1:A272. Press Copy (or Ctl+C).
Select B1. Press Paste in the top left corner of the ribbon's Home tab.
Select Paste Special and Transpose in the dialog box that opens.
Sub CopyToRange()
Dim vDB, vR()
Dim rngDB As Range
Dim Cnt As Long, i As Long, j As Integer
Dim n As Long
Set rngDB = Range("a1", Range("a" & Rows.Count).End(xlUp))
vDB = rngDB
Cnt = 272
For i = 1 To UBound(vDB, 1) Step Cnt
n = n + 1
ReDim Preserve vR(1 To Cnt, 1 To n)
For j = 1 To Cnt
If i + j - 1 > UBound(vDB, 1) Then GoTo p
vR(j, n) = vDB(i + j - 1, 1)
Next j
Next i
p:
Sheets.Add
Range("a1").Resize(n, Cnt) = WorksheetFunction.Transpose(vR)
End Sub
Sub Transp_mod2()
Dim P1 As Range, T2()
Set P1 = Sheets(3).UsedRange 'Adapt to your source column range
T1 = P1
Rws = P1.Count
Rmd = Rws
Spl = 272 'Adapt to your required steps
Cnt = 1
If Rws Mod Spl = 0 Then Rnds = Rws / Spl Else Rnds = Int(Rws / Spl) + 1
For i = 1 To Rnds
ReDim Preserve T2(1 To Spl, 1 To i)
If Rmd = Rws Mod Spl Then t = Rmd Else t = Spl
For j = 1 To t
T2(j, i) = T1(Cnt, 1)
Cnt = Cnt + 1
Rmd = Rmd - 1
Next j
Next i
Sheets(4).Range("A1").Resize(UBound(T2, 2), UBound(T2, 1)) = Application.Transpose(T2) 'Adapt "Sheets(4).range("A1")" to your destination range
End Sub
Related
i can't find where i am doing wrong my code is not working so. I'm a bit of a novice at this, I don't quite understand what the problem is
it gives me warning on this line
matrix = Range("B5").Resize(rows, cols)
Sub TamsayiliRasgeleMatris()
'Deklarasyonlar
Dim rows As Integer, cols As Integer
Dim lowerBound As Integer, upperBound As Integer
Dim sum As Double, average As Double
'Kullanıcıdan girdiler alma
rows = Range("A2").Value
cols = Range("B2").Value
lowerBound = Range("C2").Value
upperBound = Range("D2").Value
'Boş bir matris oluşturma
Dim matrix As Variant
matrix = Range("B5").Resize(rows, cols)
'Matrisi rastgele sayılarla doldurma
For i = 1 To rows
For j = 1 To cols
matrix(i, j) = Int((upperBound - lowerBound + 1) * Rnd + lowerBound)
sum = sum + matrix(i, j)
Next j
Next i
'Matrisi çalışma sayfasına yazma
matrix.Copy Destination:=Range("B5")
'Ortalama değerini hesaplayın ve E2 hücresine yazma
average = sum / (rows * cols)
Range("E2").Value = average
'Matris transpozunu oluşturun ve altına yapıştırın
Dim transposed As Variant
transposed = Application.Transpose(matrix)
transposed.Copy Destination:=Range("B5").Offset(rows + 1, 0)
'Değerleri ortalama değerine göre renklendirin
For i = 1 To rows
For j = 1 To cols
If matrix(i, j) < average Then
matrix(i, j).Interior.Color = vbCyan
ElseIf matrix(i, j) > average Then
matrix(i, j).Interior.Color = vbMagenta
End If
Next j
Next i
End Sub
Understanding Ranges and Arrays
A lot was changed so some of your comments may not apply anymore.
Option Explicit
Sub TamsayiliRasgeleMatris()
Dim ws As Worksheet: Set ws = ActiveSheet ' Improve!
'Kullanicidan girdiler alma
Dim rCount As Long: rCount = ws.Range("A2").Value
Dim cCount As Long: cCount = ws.Range("B2").Value
Dim MinInteger As Long: MinInteger = ws.Range("C2").Value
Dim MaxInteger As Long: MaxInteger = ws.Range("D2").Value
'Boş bir matris oluşturma
Dim Matrix() As Variant: ReDim Matrix(1 To rCount, 1 To cCount)
Dim r As Long, c As Long, Total As Long
'Matrisi rastgele sayilarla doldurma
For r = 1 To rCount
For c = 1 To cCount
Matrix(r, c) = Int((MaxInteger - MinInteger + 1) * Rnd + MinInteger)
Total = Total + Matrix(r, c)
Next c
Next r
ws.Range("E2").Value = Total
Dim rg As Range, fCell As Range
'Matrisi çalişma sayfasina yazma
Set fCell = ws.Range("B5")
With fCell
.Resize(ws.Rows.Count - .Row + 1, ws.Columns.Count - .Column + 1).Clear
End With
Set rg = fCell.Resize(rCount, cCount)
rg.Value = Matrix
'Ortalama degerini hesaplayin ve F2 hücresine yazma
Dim Avg As Double: Avg = Total / (rCount * cCount)
ws.Range("F2").Value = Avg
'Degerleri ortalama degerine göre renklendirin
For r = 1 To rCount
For c = 1 To cCount
Select Case Matrix(r, c)
Case Is < Avg: rg.Cells(r, c).Interior.Color = vbCyan
Case Is > Avg: rg.Cells(r, c).Interior.Color = vbMagenta
Case Else ' !?
End Select
Next c
Next r
'Matris transpozunu oluşturun ve altina yapiştirin
Dim tMatrix() As Long: ReDim tMatrix(1 To cCount, 1 To rCount)
For r = 1 To rCount
For c = 1 To cCount
tMatrix(c, r) = Matrix(r, c)
Next c
Next r
Set fCell = fCell.Offset(rCount + 1)
Set rg = fCell.Resize(cCount, rCount)
rg.Value = tMatrix
'Degerleri ortalama degerine göre renklendirin
For c = 1 To cCount
For r = 1 To rCount
Select Case tMatrix(c, r)
Case Is < Avg: rg.Cells(c, r).Interior.Color = vbCyan
Case Is > Avg: rg.Cells(c, r).Interior.Color = vbMagenta
Case Else ' !?
End Select
Next r
Next c
End Sub
Here follow some suggestion to possibly make your code run
taking in consideration the following code snippet:
Dim matrix As Variant
matrix = Range("B5").Resize(rows, cols)
since:
matrix is declared as of Variant type
Value is the default property for any Range object
then matrix is finally resulting in a Variant array, as if you had coded:
matrix = Range("B5").Resize(rows, cols).Value
further on you are coding:
matrix.Copy Destination:=Range("B5")
which would result in an error since an array doesn't have any Copy method, while this latter is available for many objects, among which the Range object
hence you should sort of "reverse" the matrix assignation code line as follows:
'Matrisi çalisma sayfasina yazma
Range("B5").Resize(rows, cols).Value = matrix
just a little more complicated is the fix of the other wrong Copy statement
Dim transposed As Variant
transposed = Application.Transpose(matrix)
transposed.Copy Destination:=Range("B5").Offset(rows + 1, 0)
which, along the lines of the preceeding fix, is to be coded as follows:
Dim transposed As Variant
transposed = Application.Transpose(matrix)
Range("B5").Offset(rows + 1, 0).Resize(cols, rows).Value = transposed
and where you'll notice I swapped cols and rows in the Resize() property to account for transposition
finally the following snippet:
'Değerleri ortalama değerine göre renklendirin
For i = 1 To rows
For j = 1 To cols
If matrix(i, j) < average Then
matrix(i, j).Interior.Color = vbCyan
ElseIf matrix(i, j) > average Then
matrix(i, j).Interior.Color = vbMagenta
End If
Next j
Next i
is to be twicked as follows:
With Range("B5") 'reference the target range upper-left cell
For i = 1 To rows
For j = 1 To cols
If matrix(i, j) < average Then
.Offset(i - 1, j - 1).Interior.Color = vbCyan 'write in the cell corresponding to the ith row and jth column of matrix
ElseIf matrix(i, j) > average Then
.Offset(i - 1, j - 1).Interior.Color = vbMagenta
End If
Next
Next
End With
I am using Excel 2016 and I am new to VBA. I have an Excel worksheet which contains 262 rows (with no headers). An extract of the first 2 rows are shown below (starts at column A and ends at column L):
I would like to run a VBA code on the worksheet to transpose the data as follows:
How should I go about it?
Try
Sub test()
Dim vDB, vR()
Dim i As Long, j As Integer, n As Long
Dim r As Long
vDB = Range("a1").CurrentRegion
r = UBound(vDB, 1)
For i = 1 To r
For j = 1 To 6
n = n + 1
ReDim Preserve vR(1 To 2, 1 To n)
vR(1, n) = vDB(i, j)
vR(2, n) = vDB(i, j + 6)
Next j
Next i
Sheets.Add
Range("a1").Resize(n, 2) = WorksheetFunction.Transpose(vR)
End Sub
A Special Transpose
Sub SpecialTranspose()
Const cLngRows As Long = 262 ' Source Number of Rows
Const cIntColumns As Integer = 6 ' Source Number of Columns Per Set
Const cIntSets As Integer = 2 ' Source Number of Sets
Const cStrSourceCell As String = "A1" ' Source First Cell
Const cStrTargetCell = "M1" ' Target First Cell
Dim vntSource As Variant ' Source Array
Dim vntTarget As Variant ' Target Array
Dim h As Integer ' Source Array Set Counter / Target Array Column Counter
Dim i As Long ' Source Array Row Counter
Dim j As Integer ' Source Array Column Counter
Dim k As Long ' Target Array Row Counter
' Resize Source First Cell to Source Range and paste it into Source Array.
vntSource = Range(cStrSourceCell).Resize(cLngRows, cIntColumns * cIntSets)
' Resize Target Array
ReDim vntTarget(1 To cLngRows * cIntColumns, 1 To cIntSets)
' Calculate and write data to Target Array.
For h = 1 To cIntSets
For i = 1 To cLngRows
For j = 1 To cIntColumns
k = k + 1
vntTarget(k, h) = vntSource(i, cIntColumns * (h - 1) + j)
Next
Next
k = 0
Next
' Paste Target Array into Target Range resized from Target First Cell.
Range(cStrTargetCell).Resize(cLngRows * cIntColumns, cIntSets) = vntTarget
End Sub
You could use arrays to do your transpose:
Sub Transpose()
'Declare variables
Dim wsHome As Worksheet
Dim arrHome, arrNumber(), arrLetter() As Variant
Dim intNum, intLetter, lr, lc As Integer
Set wsHome = ThisWorkbook.Worksheets("Sheet1")
Set collNumber = New Collection
Set collLetter = New Collection
'Set arrays to position to 0
intNum = 0
intLetter = 0
'Finds last row and column of data
lc = Cells(1, Columns.Count).End(xlToLeft).Column
lr = Cells(Rows.Count, 1).End(xlUp).Row
'Move data into array
arrHome = wsHome.Range(Cells(1, 1), Cells(lr, lc)).Value
For x = LBound(arrHome, 1) To UBound(arrHome, 1)
For y = LBound(arrHome, 2) To UBound(arrHome, 2)
'Check if value is numeric
If IsNumeric(arrHome(x, y)) = True Then
ReDim Preserve arrNumber(intNum)
arrNumber(intNum) = arrHome(x, y)
intNum = intNum + (1)
Else
ReDim Preserve arrLetter(intLetter)
arrLetter(intLetter) = arrHome(x, y)
intLetter = intLetter + 1
End If
Next y
Next x
'clear all values in sheet
wsHome.UsedRange.ClearContents
ActiveSheet.Range("A1").Resize(UBound(arrNumber), 1).Value = Application.WorksheetFunction.Transpose(arrNumber)
ActiveSheet.Range("B1").Resize(UBound(arrLetter), 1).Value = Application.WorksheetFunction.Transpose(arrLetter)
End Sub
Let us assume that data appears in Sheet 1.Try:
Option Explicit
Sub TEST()
Dim LastColumn As Long, LastRowList As Long, LastRowNumeric As Long, LastRowNonNumeric As Long, R As Long, C As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRowList = .cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .cells(1, .Columns.Count).End(xlToLeft).Column
For R = 1 To LastRowList
For C = 1 To LastColumn
If IsNumeric(.cells(R, C).Value) = True Then
LastRowNumeric = .cells(.Rows.Count, LastColumn + 2).End(xlUp).Row
If LastRowNumeric = 1 And .cells(1, LastColumn + 2).Value = "" Then
.cells(LastRowNumeric, LastColumn + 2).Value = .cells(R, C).Value
Else
.cells(LastRowNumeric + 1, LastColumn + 2).Value = .cells(R, C).Value
End If
Else
LastRowNonNumeric = .cells(.Rows.Count, LastColumn + 3).End(xlUp).Row
If LastRowNonNumeric = 1 And .cells(1, LastColumn + 3).Value = "" Then
.cells(LastRowNonNumeric, LastColumn + 3).Value = .cells(R, C).Value
Else
.cells(LastRowNonNumeric + 1, LastColumn + 3).Value = .cells(R, C).Value
End If
End If
Next C
Next R
End With
End Sub
I'm new on VBA and i need some help. I've found this code and i adapted it to my needs, but the issue is that i can't copy the first 100 cells to the next column on the same row in a table(the column E is already filled and i want to paste the values to the column F).
here is the code:
Sub variable_to_check()
Dim j As Integer, r As Range, k As Integer, dest As Range
j = 100
With Worksheets("Calibrari")
Set r = .Range("A2")
k = 0
Do
Range(r, r.Offset(j - 1, 0)).copy
With Worksheets("INCA")
Set dest = .Cells(Rows.count, "F").Offset(0, 0).End(xlUp).Offset(0, -1)
dest.PasteSpecial
'this add the text "INCA_Read" in the first column after each 100 cells
lr = ActiveSheet.Cells(Rows.count, "E").End(xlUp).Row + 1
ActiveSheet.Cells(lr, "A").value = "INCA_Read"
If k < .Range("F13").Column - 2 Then
k = k + 1
Else
k = 0
End If
End With
Set r = r.Offset(j, 0)
If r = .Range("A2").End(xlDown).Offset(1, 0) Then Exit Do
Loop
End With
ThisWorkbook.Worksheets("INCA").Cells.EntireColumn.AutoFit
End Sub
Sub value_to_be_checked() <--in this macro i think the issue is
Dim j As Integer, r As Range, k As Integer, dest As Range
j = 100
With Worksheets("Calibrari")
Set r = .Range("C2")
k = 0
Do
Range(r, r.Offset(j - 1, 0)).copy
With Worksheets("INCA")
Set dest = .Cells(Rows.count, "E").Offset(0, 0).End(xlUp).Offset(0, 1)
dest.PasteSpecial
If k < .Range("E13").Column - 2 Then
k = k + 1
Else
k = 0
End If
End With
Set r = r.Offset(j, 0)
If r = .Range("C2").End(xlDown).Offset(1, 0) Then Exit Do
Loop
End With
End Sub
Thanks!
Instead of using Copy/Paste, just set the value of the cell:
Worksheets("INCA").Cells(Rows.count, "E").End(xlUp).Offset(0, 1) = Range(r, r.Offset(j - 1, 0)).Value2
Since i find my problem hard to explain, I'll just provide an example.
This is the format of the data i have in excel in a column, separated by blanks.
A
B
C
D
E
F
G
H
I wish to transpose it so that the final result is:
A B F
C G
D H
E
How do I do that?
Here is Honorez's method:
Sub Honorez()
Dim N As Long, i As Long, j As Long, k As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 2
k = 0
For i = 1 To N
v = Cells(i, 1)
If v = "" Then
j = j + 1
k = 0
Else
k = k + 1
Cells(k, j) = v
End If
Next i
End Sub
Array method
In addition to #Gary's-Student 's fine solution, I demonstrate another approach using a datafield Array and write back values directly to the new columns:
Sub Honorez2()
Dim rng As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Honorez")
Dim i As Long, ii As Long, j As Long, m As Long, n As Long
Dim a()
' get data
n = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range("A1:A" & n)
rng.Offset(0, 1).Resize(n, n - WorksheetFunction.CountA(Range("A:A")) + 1) = "" ' clear prior values
' write data field to array
a = rng
j = 2 ' start column for results
For i = 1 To n
If a(i, 1) = "" Or i = n Then
' write data to new column
ws.Range(ws.Cells(1, j), ws.Cells(i - ii, j)).Value = _
ws.Range(ws.Cells(ii + 1, 1), ws.Cells(i, 1)).Value
' remember row and increment column counter
ii = i: j = j + 1
End If
Next i
End Sub
Column A contains the labels or outcome value, Columns B-N contain varying lengths of comma separated values, but range for each column is the same (i.e., 1-64). The goal is to covert to a new table with Column A representing the value range (1-64) and Columns B-N the labels/outcome from the original table.
A semi-related solution was sought here, but without use of macros.
I will let you to modify this code,
Sub splitThem()
Dim i As Long, j As Long, k As Long, x As Long
x = 1
Sheets.Add.Name = "newsheet"
For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(i, j) <> "" Then
For k = 1 To Len(Cells(i, j)) - Len(Replace(Cells(i, j), ",", "")) + 1
Sheets("newsheet").Cells(x, j) = Cells(i, 1)
x = x + 1
Next k
End If
Next i
x = 1
Next j
End Sub
Try this code.
Sub test()
Dim vDB, vR()
Dim vSplit, v As Variant
Dim Ws As Worksheet
Dim i As Long, n As Long, j As Integer, c As Integer
vDB = Range("a2").CurrentRegion
n = UBound(vDB, 1)
c = UBound(vDB, 2)
ReDim vR(1 To 64, 1 To c)
For i = 1 To 64
vR(i, 1) = i
Next i
For i = 2 To n
For j = 2 To c
vSplit = Split(vDB(i, j), ",")
For Each v In vSplit
vR(v, j) = vDB(i, 1)
Next v
Next j
Next i
Set Ws = Sheets.Add '<~~ replace your sheet : Sheets(2)
With Ws
For i = 1 To c
.Range("b1")(1, i) = "COND" & i
Next i
.Range("a2").Resize(64, c) = vR
End With
End Sub