Solved: Transpose data from one sheet to another

[Johnosley]

I have a basic excel table with 8 columns and a amount of row that could vary.

I need to transpose all data. First row will be copied/pasted to column A depending the row number.

Everything is working. See code below.

In my column 4 I have a Province code which could for example "BC - British Columbia". I need to transpose only the "BC". I tried to use the left function but the macro returns a blank for this cell !

Any thoughts ? Thanks

Public Sub ProcessData()
Dim i As Long, j As Long
Dim LastRow As Long
Dim province As String
Dim prov As String

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For i = 2 To LastRow

For j = 1 To 8

If j = 4 Then
province = Cells(i, j).Text
prov = Left(province, 2)
Sheets("sheet2").Select
Range("A" & 8 * (i - 2) + j + 1).Value = prov
Else
.Cells(i, j).Copy
Sheets("Sheet2").Select
Range("A" & 8 * (i - 2) + j + 1).Select
ActiveSheet.Paste
End If

Next j

Next i

End With

End Sub

[GTO]

A sample wb would be my thought. Just from what's posted, I would dump the initial range into an array, run thru 'column' 4 of the array and fix 'BC' there, then transpose the array and dump it into the destination.

[Johnosley]

A sample wb would be my thought. Just from what's posted, I would dump the initial range into an array, run thru 'column' 4 of the array and fix 'BC' there, then transpose the array and dump it into the destination.

I understand the idea but I'm not familiar with the concept of array and how to deal with it.

I attached a spreadsheet showing my current problem.

In fact I'm able to deal with the previous issue (ie "BC" rather than "BC - .....") but now I'm trying to copy/paste/transpose line based on a specific value on column A (Y or blank).

could the array help me to solve this problem ?

[GTO]

Hi again,

I believe I commented the code decently; try:

In a Standard Module:


Option Explicit

Sub TransposeByCriteria()
Dim _
rngData As Range, _
rngTemp As Range, _
lRightCol As Long, _
i As Long, _
x As Long, _
aryInput As Variant, _
aryOutput As Variant

'// First row of data, change to suit //
Const STARTING_ROW As Long = 2

'// You could use .Find to set the last column, we just use an input box here //
lRightCol = Application.InputBox("How many columns?", vbNullString, , , , , , 1)
'// In case user cancels or doesn't put an appropriate column number in, bail here //
'// to prevent error. //
If lRightCol = 0 _
Or lRightCol > ThisWorkbook.Worksheets(1).Columns.Count Then
Exit Sub
End If

With Sheet1 '<---Codename or Worksheet name---> With ThisWorkbook.Worksheets ("Sheet1")

'// Set an initial reference to include all rows... //
Set rngData = .Range(.Cells(STARTING_ROW, 1), .Cells(.Rows.Count, lRightCol))
'// ...then find the last row with data... //
Set rngTemp = RangeFound(SearchRange:=rngData, StartingAfter:=rngData(1))
'// ...and 'reset' our data range. //
Set rngData = .Range(.Cells(STARTING_ROW, 1), .Cells(rngTemp.Row, lRightCol))

'// plunk the values into an array, and give an initial size to our output array//
aryInput = rngData.Value
ReDim aryOutput(0 To 0)

'// See vba help for L/UBound, basically the most assured way to run thru the //
'// array. Note that we are just running down the first 'column' of the array, //
'// looking for the "Y"'s, just like on the sheet. //
For i = LBound(aryInput, 1) To UBound(aryInput, 1)

If aryInput(i, 1) = "Y" Then
'// Resize our output array on the fly. Note that we bump the base of //
'// the array the first time through. //
ReDim Preserve aryOutput(1 To UBound(aryOutput, 1) + lRightCol - 1)

'// Enter data into our output, excepting the last one... //
For x = 2 To lRightCol - 1
aryOutput(UBound(aryOutput, 1) - (lRightCol - x)) = aryInput(i, x)
Next

'// ...and just grab the two-letter designator for the last element. //

'// to return BC - British Columbia //
'aryOutput(UBound(aryOutput, 1)) = aryInput(i, lRightCol)
'// to return BC, AB, etc //
aryOutput(UBound(aryOutput, 1)) = _
IIf(aryInput(i, lRightCol) Like "[A-Z][A-Z]*", _
Left(aryInput(i, lRightCol), 2), _
aryInput(i, lRightCol))
End If
Next
End With

'// plunk the output array wherever you want.//
Sheet3.Range("A1").Resize(UBound(aryOutput)).Value = Application.Transpose(aryOutput)
End Sub

Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function

Hope that helps,

Mark

[Johnosley]

Hi again,

I believe I commented the code decently; try:

Mark

Fabulous ! Thank you so much. It works and I was able to understand (almost :)) your step and it was easy to adapt to my needs.

The only thing is not working is this part

aryOutput(UBound(aryOutput, 1)) = _
IIf(aryInput(i, lRightCol) Like "[A-Z][A-Z]*", _
Left(aryInput(i, lRightCol), 2), _
aryInput(i, lRightCol))

I understand that you are doing but don't know why it's not working.

In my case, the "AB - xxxx" is on column 5 so I changed lRightCol to 5 but didn't work.

[GTO]

By recollection, in the example file, there were 5 columns, A-E. It worked fine with the supplied data.

Does 'not working' mean an error, only one letter returned, ect?

[Johnosley]

By recollection, in the example file, there were 5 columns, A-E. It worked fine with the supplied data.

Does 'not working' mean an error, only one letter returned, ect?

Oh I see ! I made the mistake ! I forgot that my example had only 5 columns. See attached the final one I'm using.

And yes, it works fine with my first example. Sorry for the confusion.

[GTO]

Hi John,

Your amended example does not have the code in it, which is fine, but left me wondering... Were you able to adapt the code to work?

Mark

[Johnosley]

Hi John,

Your amended example does not have the code in it, which is fine, but left me wondering... Were you able to adapt the code to work?

Mark

see attached my amended file with your code. Works fine (except the "AB" but I can deal with that)

Thanks

[mdmackillop]

Option Explicit
Option Compare Text
Sub Trans()
Dim Rng As Range
Dim tgt As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim Crit As String
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet3")
Set Rng = ws1.Cells(1, 1).CurrentRegion.Columns(5)
Crit = InputBox("Text to find, eg AB")
With ws1
For i = 2 To Rng.Cells.Count
If Left(.Cells(i, 5), 2) = Crit Then
'or
'If .Cells(i, 1) = "Y" Then
Set tgt = ws2.Cells(Rows.Count, 5).End(xlUp)(2)
.Cells(i, 1).Offset(, 1).Resize(, 7).Copy
tgt.PasteSpecial Paste:=xlValues, Transpose:=True
End If
Next
End With
ws2.Cells(1, 5).Delete shift:=xlUp
End Sub