Copy Excel data from columns to rows with VBA - excel

I have a little experience with VBA, and I would really appreciate any help with this issue. In a basic sense, I need to convert 2 columns of data in sheet 1 to rows of data in sheet 2.
It currently looks like this in Excel:
And I need it to look like this:
I've already written the code to transfer the headings over to sheet 2, and it works fine. I'm just having issues with transferring the actual values in the correct format. Right now, the body of my code is
ws.Range("B3").Copy
ws2.Range("C2").PasteSpecial xlPasteValues
ws.Range("B4").Copy
ws2.Range("D2").PasteSpecial xlPasteValues
ws.Range("B5").Copy
ws2.Range("E2").PasteSpecial xlPasteValues
ws.Range("B6").Copy
ws2.Range("F2").PasteSpecial xlPasteValues
continued on and on. However, this really won't work, as the actual document I'm working on has tens of thousands of data points. I know there's a way to automate this process, but everything I've tried has either done nothing or given an error 1004.
Any help with this would be greatly appreciated!!
Edit: There are hundreds of little sections of data, each 18 rows long (1 row for the frame #, 1 row for the time, and 1 row for each of the 16 channels). I'm trying to get it into a loop with a step size of 18. Is that possible? I'm fine with loops, but I've never done a loop with copying and pasting cell values

Try this code:
Dim X() As Variant
Dim Y() As Variant
X = ActiveSheet.Range("YourRange").Value
Y = Application.WorksheetFunction.Transpose(X)
Also check out this link: Transpose a range in VBA

This method leverages loops and arrays to transfer the data. It isn't the most dynamic method but it gets the job done. All the loops use existing constants, so if your data set changes you can adjust the constants and it should run just fine. Make sure to adjust the worksheet names to match the names you are using in your excel document. In effect, what this is doing is loading your data into an array and transposing it onto another worksheet.
If your data set sizes change quite a bit, you will want to include some logic to adjust the loop variables and array size declarations. If this is the case, let me know and I'll figure out how to do that and post an edit.
Sub moveTimeData()
Set source = ThisWorkbook.Sheets("RawData")
Set dest = ThisWorkbook.Sheets("TransposeSheet")
Const dataSetSize = 15
Const row15Start = 3
Const row15End = 18
Const row30Start = 21
Const row30End = 36
Const colStart = 2
Const destColStart = 2
Const dest15RowStart = 2
Const dest30RowStart = 3
Dim time15Array() As Integer
Dim time30Array() As Integer
ReDim time15Array(0 To dataSetSize)
ReDim time30Array(0 To dataSetSize)
Dim X As Integer
Dim Y As Integer
Dim c As Integer
c = 0
For X = row15Start To row15End
time15Array(c) = source.Cells(X, colStart).Value
c = c + 1
Next X
c = 0
For X = row30Start To row30End
time30Array(c) = source.Cells(X, colStart).Value
c = c + 1
Next X
For X = 0 To dataSetSize
dest.Cells(dest15RowStart, X + destColStart).Value = time15Array(X)
Next X
For X = 0 To dataSetSize
dest.Cells(dest30RowStart, X + destColStart).Value = time30Array(X)
Next X
End Sub
EDIT-> I think this is what you are looking for after reading your edits
Sub moveTimeData()
Set source = ThisWorkbook.Sheets("RawData")
Set dest = ThisWorkbook.Sheets("TransposeSheet")
Const numberDataGroups = 4
Const dataSetSize = 15
Const stepSize = 18
Const sourceRowStart = 3
Const sourceColStart = 2
Const destColStart = 2
Const destRowStart = 2
Dim X As Integer
Dim Y As Integer
Dim currentRow As Integer
currentRow = destRowStart
For X = 0 To numberDataGroups
For Y = 0 To dataSetSize
dest.Cells(currentRow, Y + destColStart).Value = source.Cells((X * stepSize) + (Y + sourceRowStart), sourceColStart)
Next Y
currentRow = currentRow + 1
Next X
End Sub
Now the key to this working is knowing how many groups of data you are dealing with after the data dump. You either need to include logic for detecting that or adjust the constant called numberDataGroups to reflect how many groups you have. Note: I leveraged a similar technique for traversing arrays that have their data stored in Row Major format.

Use Copy, then Paste Special+Transpose to turn your columns into rows:
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

Try this:
Sub TansposeRange()
Dim InRange As Range
Dim OutRange As Range
Dim i As Long
Set InRange = Sheet1.Range("B3:B10002")
Set OutRange = Sheet2.Range("C2")
InRange.Worksheet.Activate
InRange.Select
Selection.Copy
OutRange.Worksheet.Activate
OutRange.Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End Sub

This is a way to do it using a loop, here illustrated with a step of 2
Notice that you have to specify the OutRange precisely the correct size (here NTR2 is the 10001's cell of the 2nd row).
Sub TansposeRange()
Dim InRange As Range
Dim OutRange As Range
Dim i As Long
Set InRange = Sheet1.Range("B3:B10002")
Set OutRange = Sheet2.Range("C2:NTR2")
For i = 1 To 10000 Step 2
OutRange.Cells(1, i) = InRange.Cells(i, 1)
Next i
End Sub

'The following code is working OK
Sub TansposeRange()
'
' Transpose Macro
'
Dim wSht1 As Worksheet
Dim rng1 As Range
Dim straddress As String
Set wSht1 = ActiveSheet
On Error Resume Next
Set rng1 = Application.InputBox(Prompt:="Select Columns or Rows to transpose", _
Title:="TRANSPOSE", Type:=8)
If rng1 Is Nothing Then
MsgBox ("User cancelled!")
Exit Sub
End If
straddress = InputBox(Prompt:="Full cell Address as Sheet2!A1", _
Title:="ENTER Full Address", Default:="Sheet1!A1")
If straddress = vbNullString Then
MsgBox ("User cancelled!")
Exit Sub
End If
Application.ScreenUpdating = False
rng1.Select
rng1.Copy
On Error GoTo 0
'MsgBox straddress
Range(straddress).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.ScreenUpdating = True
End Sub

Related

VBA : Loop until a random row is not hidden

We are trying this trick for a while !
We have a range of 'x' rows, and we would like to make a random sample of 35 rows by hiding all others.
The difficult mission for us is to make all random row unique (to avoid hiding a row already hide).
For that, we tried to make a loop, with a check if the row is already hide.
We tried to make this code, but it's not working :
Function randSample(Rg As Range) As Range
Set randSample = Rg.Rows(Int(Rnd * Rg.Rows.Count) + 1)
End Function
Sub sampling()
Dim N As Long, i As Integer, Raw As Range, myRange As Range, sampleRangeCount As Long
N = Cells(12, 1).End(xlDown).Row
Set myRange = Range("A12:AW" & N)
sampleRangeCount = myRange.Rows.Count - 35
Application.ScreenUpdating = False
Randomize
For i = 1 To sampleRangeCount
Do
Set Raw = randSample(myRange)
Loop Until Raw.EntireRow.Hidden = False
Raw.EntireRow.Hidden = True
Next
Application.ScreenUpdating = True
End Sub
Could you help us for that? Where are we wrong?
Thank you a lot!
Kevin

VBA code too slow - takes 6 hours to execute output

I have a lengthy code unable to share the 8000+ liner code completely, The code runs through loops multiple times row by row, if there are 10000+ rows then loop runs 10000+ times.
Since the code is too lengthy I am sharing a part of it were I feel it can shorten the time taken, But I am missing a loop in it and how do I include that Is my query for now.
I’ll be sharing the original code and very next is the replacement code kindly check and let me know we’re and how to include.
Original code:
For i = 2 To endlineMM
If worksheets(“MM Source”).cells(I,9).value = “registered locked” or worksheets(“MM Source”).cells(i,9).value = “registered unlocked” Then
For j = 3 to endlineDHDO
If instr(Lcase(worksheets(“DHDO”).cells(j,2).value),Lcase(Worksheets(“MM Source”).cells(i,2).value)) <> 0 Then
If Lcase(Worksheets(“MM Source”).cells(i,2).value) = Lcase(worksheets(“DHDO”).cells(j,2).value) Then
Found missing = True
Exit For
Else if j= EndlineDHDO And Lcase(Worksheets(“MM Source”).cells(i,2).value)<>
Lcase(worksheets(“DHDO”).cells(j,2).value) Then
Foundmissing = false
End if
Next j
If foundmissing = False Then
Etc......
Replacement code:
For i = 2 to endlineMM
If worksheets(“MM Source”).cells(I,9).value = “registered locked” or worksheets(“MM Source”).cells(i,9).value = “registered unlocked” Then
Test_ID = Worlsheets(“MM Source”).cells(i,2).value
With sheets(“DHDO”).Range(“B:B“)
Set prg = .Find(Test_ID, LookIn:=xlvalues)
If prg is nothing then
Foundmissing =true
Exit for
Else
Foundmissing = false
End if
End with
If foundmissing = false Then
Etc......
If you observe above from original code it has “i“ as well as “j” but in replacement code I am missing “j”
How can I fix my Replacement code
let me know how to edit the Replacement code please
Generally speaking, your code will run a lot faster if you use Ranges and Arrays rather than individual Cells.
For example, if you were to take a spreadsheet and fill columns A1:B10000, with numeric data, and then compare the performance of the two following codes:
Dim data As Variant
Dim output(10000) As Double
Dim i As Integer
data = Application.Transpose(Application.Transpose(Range("A1", "B10000")))
For i = 1 To 10000
output(i - 1) = data(i, 1) + data(i, 2)
Next
Range("C1", "C10000").Value = Application.Transpose(output)
and
Dim i As Integer
For i = 1 To 10000
Cells(i, 3).Value = Cells(i, 1).Value + Cells(i, 2).Value
Next
You will notice that the first variation is considerably faster.
By way of explanation Application.Transpose is necessary to assign the range to an array. It needs to be doubled in the first case, because it is a two-dimensional array.
Here is a sample that will filter the MM Source sheet, then loop through the visible cells finding cells in DHDO sheet
Sub Do_It()
Dim sh As Worksheet, ws As Worksheet
Dim rng As Range, c As Range
Dim a As Range
Set sh = Sheets("MM Source")
Set ws = Sheets("DHDO")
Application.ScreenUpdating = False
With sh
Set rng = .Range("I2:I" & .Cells(.Rows.Count, "I").End(xlUp).Row)
.Columns("I:I").AutoFilter Field:=1, Criteria1:= _
"=registered locked", Operator:=xlOr, Criteria2:="=registered unlocked"
For Each c In rng.SpecialCells(xlCellTypeVisible).Cells
Set a = ws.Range("B:B").Find(c.Offset(, -7), LookIn:=xlValues)
If Not a Is Nothing Then
'MsgBox "Do nothing"
Else
'MsgBox "Do something"
c.Interior.Color = vbGreen
End If
Next c
.AutoFilterMode = False
End With
End Sub

Getting a 'Range' of object '_Global' failed (Run-Time Error 1004) when running an Excel macro

These are the steps of the macro:
This macro is supposed to select A1 and enter it as a blank space to reiterate the random variables in the excel sheet.
Select the output from the random inputs and copy it.
Select a place to output the copied date, in this case "Row 200, Column(n)" and then paste each set of results in a new column as n iterates.
I'm getting a 1004 range error, and I'm not sure how to fix it. What am I missing?
Sub newloop()
'
' newloop Macro
'
Dim n As Integer
n = 1
Do Until n = 5
Range("A1").Select
ActiveCell.FormulaR1C1 = ""
Range("AA25,AA47,AA69,AA91,AA113,AA135,AA157,AA179,AA201,AA223,AA245,AA267,AA289").Select
Selection.Copy
Range("R200C" & n).Select
ActiveSheet.Paste
n = n + 1
Loop
End Sub
other than fixing the range syntax error, you can avoid changing A1 cell at every iteration since sheet calculation would be triggered at every copy/paste operation:
Sub newloop()
Dim n As Integer
Range("A1").Value = "" ' trigger first sheet calculation
With Range("AA25,AA47,AA69,AA91,AA113,AA135,AA157,AA179,AA201,AA223,AA245,AA267,AA289") ' reference input range
For n = 1 To 5
.Copy Cells(200, n) ' copy referenced range and paste it to current nth column from row 200 downwards
Next
End With
End Sub
even better, have sheet calculate directly by means of Calculate method:
Sub newloop()
Dim n As Integer
ActiveSheet.Calculate
With Range("AA25,AA47,AA69,AA91,AA113,AA135,AA157,AA179,AA201,AA223,AA245,AA267,AA289")
For n = 1 To 5
.Copy Cells(200, n)
Next
End With
End Sub
The R1C1 notation is not supported in Range() as a parameter. Thus, change:
Range("R200C" & n).Select
with:
Cells(200,n).Select
and the error would dissappear.
The Solution
It is a good habit to use constants at the beginning of the code, so you can
quickly change something and observe the behavior of the code e.g. you want to paste the data into the 500th row or you want 10 times the results instead of 5, or you want to add another cell range...
Sub NewLoop()
Const cStrRange As String = "AA25,AA47,AA69,AA91,AA113,AA135,AA157," & _
"AA179,AA201,AA223,AA245,AA267,AA289"
Const cLngRow As Long = 200
Const cN As Integer = 5
Dim oRng As Range
Dim n As Integer
Set oRng = Range(cStrRange)
For n = 1 To cN
Range("A1").FormulaR1C1 = ""
oRng.Copy Cells(cLngRow, n)
Next
End Sub
Missing the Point
When you don't read the OP's wishes carefully:
Exemplary, Short and Shorter
Option Explicit
Sub NewLoopExemplary()
Const cStrA As String = "A1"
Const cStrRange As String = "AA25,AA47,AA69,AA91,AA113,AA135,AA157," & _
"AA179,AA201,AA223,AA245,AA267,AA289"
Const cLngRow As Long = 200
Const cN As Integer = 5
Dim oRng As Range
Range(cStrA).FormulaR1C1 = ""
Set oRng = Range(cStrRange)
oRng.Copy Cells(cLngRow, 1).Resize(1, cN)
End Sub
Sub NewLoopShort()
Const n As Integer = 5
Range("A1").FormulaR1C1 = ""
Range("AA25,AA47,AA69,AA91,AA113,AA135,AA157,AA179,AA201,AA223,AA245,AA267," _
& "AA289").Copy Cells(200, 1).Resize(1, n)
End Sub
Sub NewLoopShorter()
Range("A1").FormulaR1C1 = ""
Range("AA25,AA47,AA69,AA91,AA113,AA135,AA157,AA179,AA201,AA223,AA245,AA267," _
& "AA289").Copy Cells(200, 1).Resize(1, 5)
End Sub

Delete rows based off blank cells in a range

I am trying to delete blank rows in a range
My code looks like this :
Dim rng As Range
Dim i As Long, counter As Long
i = 1
Range("B1").Select
Selection.End(xlDown).Offset(0, 5).Select
Set rng = Range("G2", ActiveCell)
Range("G2").Select
For counter = 1 To rng.Rows.Count
If rng.Cells(i) = "" Then
rng.Cells(i).EntireRow.Delete
Else
i = i + 1
End If
Next
So, hmqcnoesy has kindly helped me solve the error message. The variables should be Dimmed as LONG not INTEGER because integer can not hold as big a number for all my rows of data
Also, Jon49 gave me some code that was much mroe efficient for this process:
Dim r1 As Range 'Using Tim's range.
Set r1 = ActiveSheet.Range(Range("G2"),Range("B1").End(xlDown).Offset(0, 5))
'Delete blank cell rows.
r1.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Set r1 = Nothing
It looks like you should try using type Long for i and counter. Using Integer causes an overflow, at least in newer versions of Excel, where there are over 1 million rows in a worksheet.
Here's some simpler code for you:
Dim r1 As Range
'Using Tim's range.
Set r1 = ActiveSheet.Range(Range("G2"),Range("B1").End(xlDown).Offset(0, 5))
'Delete blank cell rows.
r1.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Set r1 = Nothing
Dim rng As Range
Dim counter As Long
Set rng = Range(Range("G2"),Range("B1").End(xlDown).Offset(0, 5))
For counter = rng.Rows.Count to 1 Step -1
If Len(rng.Cells(counter).Value) = 0 Then rng.Cells(counter).EntireRow.Delete
Next

Transpose Excel data using VBA

I have Excel data that looks like the top two rows of the following:
I need to get it looking like the data on the bottom rows.
A very easy way of doing this is by using the transpose option of Paste Special, depending on how much data you have. For a small amount it's worth doing it this way.
Select B1:E1
Copy.
Select where you want it pasted.
Go to Edit, Paste Special and choose transpose
It will now be shown vertically. Just fill in the name Joe Bloggs and fill it down.
If you have a lot of different people, Joe Bloggs, Jane Doe and many more it would be a chore to transpose each individual person so a quick bit of VB code like horrible thing below should do the trick.
Public Sub test()
Dim rowFound As Boolean, columnFound As Boolean, y As Long, x As Long, rowCounter As Long
Dim thisSheet As Excel.Worksheet, resultSheet As Excel.Worksheet
Set thisSheet = ActiveWorkbook.Sheets("Sheet1")
Set resultSheet = ActiveWorkbook.Sheets("Sheet2")
rowFound = True
y = 0
rowCounter = 0
Do While rowFound
columnFound = True
Dim foundName As String
foundName = thisSheet.Range("A1").Offset(y).Value
If foundName = "" Then
rowFound = False
Else
x = 0
Do While columnFound
If thisSheet.Range("B1").Offset(y, x).Value = "" Then
columnFound = False
Else
resultSheet.Range("A1").Offset(rowCounter).Value = foundName
resultSheet.Range("B1").Offset(rowCounter).Value = thisSheet.Range("B1").Offset(y, x).Value
rowCounter = rowCounter + 1
End If
x = x + 1
Loop
End If
y = y + 1
Loop
End Sub
x and y are used like a set of graph coordinates. For every row it scans through the columns in the row, and adds it to the list below.
Edit:
I've updated the code, Integers are now Long and it writes the results to sheet2.

Resources