Hi,
I was wondering if someone could help with this moving data from multiple columns to 2 columns (Examples attached)
[ATTACH=CONFIG]71197[/ATTACH]forum.ozgrid.com/index.php?attachment/71198/
Thanks
Hi,
I was wondering if someone could help with this moving data from multiple columns to 2 columns (Examples attached)
[ATTACH=CONFIG]71197[/ATTACH]forum.ozgrid.com/index.php?attachment/71198/
Thanks
Re: Move Data from multiple columns to 2 columns
Based on the test sheet you supplied, the following code should work to transpose the "round" data from Sheet1 to Sheet2
Option Explicit
Sub TransposeData()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim rRange As Range
Dim lLC As Long, lRC As Long, lTR As Long, lBR As Long
Dim loLC As Long, loTR As Long
Dim k As Long
'speed up processing
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'setup the worksheet variables
'sheet 1 in this workbook is assumed to contain the input
'sheet 2 in this workbook is assumed to be where the transposed output is written
Set wsInput = ThisWorkbook.Sheets(1)
Set wsOutput = ThisWorkbook.Sheets(2)
'locate the 'anchor' point on sheet 1, assumed to contain the word "round"
Set rRange = wsInput.UsedRange.Find("round", LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If rRange Is Nothing Then
MsgBox "Unable to locate input data", vbExclamation Or vbSystemModal, "Warning"
GoTo QuickExit
End If
'set up the co-ordinates of the input data
With rRange
lLC = .Column
lTR = .Row
End With
'locate the last row and column of input data
With wsInput
lBR = .Cells(.Rows.Count, lLC).End(xlUp).Row
lRC = .Cells(lTR, .Columns.Count).End(xlToLeft).Column
End With
'check to see if there is some data to copy
If lBR <= lTR Or lRC <= lLC Then
MsgBox "No data to copy", vbExclamation Or vbSystemModal, "Warning"
GoTo QuickExit
End If
'pick an arbitrary point on the output sheet to copy data to
loLC = 2
loTR = 2
'clear the used range on the output sheet if required
wsOutput.UsedRange.ClearContents
'need to copy data from the data rows
For k = lTR + 1 To lBR
'copy the round number first
wsOutput.Cells(loTR + (lRC - lLC) * (k - (lTR + 1)), loLC).Value = wsInput.Cells(k, lLC).Value
With wsInput
'the top row is transposed for each round
.Range(.Cells(lTR, lLC + 1), .Cells(lTR, lRC)).Copy
wsOutput.Cells(loTR + (lRC - lLC) * (k - (lTR + 1)), loLC + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
'now transpose the data row to the output sheet
.Range(.Cells(k, lLC + 1), .Cells(k, lRC)).Copy
wsOutput.Cells(loTR + (lRC - lLC) * (k - (lTR + 1)), loLC + 2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
Next
With Application
.CutCopyMode = False
'optionally move to the output sheet
.Goto wsOutput.Cells(loLC, loTR), True
End With
'if we got to here, data transposition was successful
MsgBox "Data transposed to " & wsOutput.Name, vbInformation, "Information"
QuickExit:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
'tidy up
Set wsInput = Nothing: Set wsOutput = Nothing
Set rRange = Nothing
End Sub
Display More
The code assumes that the data exists in Sheet1 and is anchored by the cell with the word "round" in it.
It also assumes that Sheet2 exists for writing the output to.
Other than that it can work with any number of columns and rows starting at the anchor cell on Sheet1.
Re: Move Data from multiple columns to 2 columns
Gigsmo, Thats exactly what I asked for....... Thank you...... However I made an error :(, I understand about 60% of your code and I have had a play with it (No joy) but on sheet 1 row 7 should be ignored!!! in the example that I supplied there should only be 4 games in round 1....... Totally my mistake & I apologise for wasting some of your time!
can you show me how I can adjust your code please?
[ATTACH=CONFIG]71201[/ATTACH]
Re: Move Data from multiple columns to 2 columns
OK, so the code needs to be slightly adjusted to look at the number of teams, just needs another Find to get this sorted:
Option Explicit
Sub TransposeData()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim rRange As Range
Dim lLC As Long, lRC As Long, lTR As Long, lBR As Long
Dim loLC As Long, loTR As Long
Dim lTeams As Long, k As Long
'speed up processing
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'setup the worksheet variables
'sheet 1 in this workbook is assumed to contain the input
'sheet 2 in this workbook is assumed to be where the transposed output is written
Set wsInput = ThisWorkbook.Sheets(1)
Set wsOutput = ThisWorkbook.Sheets(2)
'locate the data 'anchor' point on sheet 1, below which are the data rows
Set rRange = wsInput.UsedRange.Find("round", LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If rRange Is Nothing Then
MsgBox "Unable to locate input data", vbExclamation Or vbSystemModal, "Warning"
GoTo QuickExit
End If
'set up the top co-ordinates of the input data
With rRange
lLC = .Column
lTR = .Row
End With
'locate the number of teams 'anchor' point on sheet 1, below which is the number we want
Set rRange = wsInput.UsedRange.Find("no of teams", LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If rRange Is Nothing Then
MsgBox "Unable to locate No of Teams", vbExclamation Or vbSystemModal, "Warning"
GoTo QuickExit
End If
'work out the number of teams
With wsInput
'check this just in case
If Not WorksheetFunction.IsNumber(.Cells(rRange.Row + 1, rRange.Column).Value) Then
MsgBox "No of Teams is not numeric", vbExclamation Or vbSystemModal, "Warning"
GoTo QuickExit
End If
'convert to longint, just in case of decimal data
lTeams = CLng(.Cells(rRange.Row + 1, rRange.Column).Value)
'must have at least 1 team to process
If lTeams <= 0 Then
MsgBox "No of Teams must be greater than 0", vbExclamation Or vbSystemModal, "Warning"
GoTo QuickExit
End If
End With
'locate the last row and column of input data
With wsInput
lBR = lTR + lTeams
lRC = .Cells(lTR, .Columns.Count).End(xlToLeft).Column
End With
'check to see if there is some data to copy
If lBR <= lTR Or lRC <= lLC Then
MsgBox "No data to copy", vbExclamation Or vbSystemModal, "Warning"
GoTo QuickExit
End If
'pick an arbitrary point on the output sheet to copy data to
loLC = 2
loTR = 2
'clear the used range on the output sheet if required
wsOutput.UsedRange.ClearContents
'need to copy data from the data rows
For k = lTR + 1 To lBR
'copy the round number first
wsOutput.Cells(loTR + (lRC - lLC) * (k - (lTR + 1)), loLC).Value = wsInput.Cells(k, lLC).Value
With wsInput
'the top row is transposed for each round
.Range(.Cells(lTR, lLC + 1), .Cells(lTR, lRC)).Copy
wsOutput.Cells(loTR + (lRC - lLC) * (k - (lTR + 1)), loLC + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
'now transpose the data row to the output sheet
.Range(.Cells(k, lLC + 1), .Cells(k, lRC)).Copy
wsOutput.Cells(loTR + (lRC - lLC) * (k - (lTR + 1)), loLC + 2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
Next
With Application
.CutCopyMode = False
'optionally move to the output sheet
.Goto wsOutput.Cells(loLC, loTR), True
End With
'if we got to here, data transposition was successful
MsgBox "Data transposed to " & wsOutput.Name, vbInformation, "Information"
QuickExit:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
'tidy up
Set wsInput = Nothing: Set wsOutput = Nothing
Set rRange = Nothing
End Sub
Display More
The extra bit of code looks for the "No of Teams" on Sheet1 and uses the number in the cell immediately below this to work out the number of data rows.
There's also a bit of validation to ensure the value in that cell is actually a number, etc
Re: Move Data from multiple columns to 2 columns
Gigsmo, It does check for a numeric value & that part works fine, thanks...... However it is still returning the wrong pairings & too many games if you check pic 4.jpg, that is what it should return with 8 teams , there should only be 4 games in each round when there are 8 teams, Note: Rnd 1 is in row 8....... & the first game is H G, then F E etc
This stems from my original mistake.... Sorry! I hope you can help because this would be really helpful.... Thanks in advance
Re: Move Data from multiple columns to 2 columns
Here is an alternative method for you to try, click the button on Sheet1
Code assigned to the button is
Option Explicit
Sub CreateRounds()
Dim x, y, i As Integer, ii As Integer, iii As Integer
x = Sheet1.Cells(7, 3).CurrentRegion
ReDim y(1 To 7 * ((UBound(x, 2) - 1) / 2), 1 To 3)
iii = 1
For i = 2 To UBound(x, 1)
y(iii, 1) = x(i, 1)
For ii = 2 To UBound(x, 2) Step 2
y(iii, 2) = x(i, ii): y(iii, 3) = x(i, ii + 1)
iii = iii + 1
Next
Next
With Sheet2.Cells(2, 2)
.CurrentRegion.Clear
.Resize(UBound(y, 1), 3) = y
End With
Application.Goto Sheet2.[a1], 1
End Sub
Display More
Re: Move Data from multiple columns to 2 columns
KjBox, That gives the correct output, thanks...... Can the code ignore data in col A & B?...... I have data in there & the code hangs up if there is data that 2 columns.........
Re: Move Data from multiple columns to 2 columns
Sorry guys, I should have stated that I have data in col A & B on sheet 1 that I am getting an error with.
Re: Move Data from multiple columns to 2 columns
wrong post
Re: Move Data from multiple columns to 2 columns
Change the code to this
Option Explicit
Sub CreateRounds()
Dim x, y, i As Integer, ii As Integer, iii As Integer
With Sheet1
i = .Cells(.Rows.Count, 3).End(xlUp).Row
ii = .Cells(7, .Columns.Count).End(xlToLeft).Column
x = .Cells(7, 3).Resize(i - 7, ii - 2).Value
End With
ReDim y(1 To 7 * ((UBound(x, 2) - 1) / 2), 1 To 3)
iii = 1
For i = 2 To UBound(x, 1)
y(iii, 1) = x(i, 1)
For ii = 2 To UBound(x, 2) Step 2
y(iii, 2) = x(i, ii): y(iii, 3) = x(i, ii + 1)
iii = iii + 1
Next
Next
With Sheet2.Cells(2, 2)
.CurrentRegion.Clear
.Resize(UBound(y, 1), 3) = y
End With
Application.Goto Sheet2.[a1], 1
End Sub
Display More
Re: Move Data from multiple columns to 2 columns
KjBox, Yup, that did the trick.... Thanks so much :spin:
Gigsmo, I would be interested in your code if that could be adapted to give the same output (I would like to try & have a play with both codes to try & "learn" a bit more)
Re: Move Data from multiple columns to 2 columns
KjBox, looks like I was little early....... There is a problem when there is more than 8 teams (Could be between 4 & 20 teams, so that would be a possible 19 rounds), it hangs up
There is a team counter in cell D3 on sheet 1 if that would help make it dynamic?
Re: Move Data from multiple columns to 2 columns
Guys,
I've attached a 2nd example test sheet (just noticed the last update is short of 1 round), I have put buttons on the sheet to call up 6, 10 & 20 teams so any adjusted code can be tested.
Example of rounds
6 teams = 5 rounds
10 teams = 9 rounds
20 teams = 19 rounds
Thanks
Re: Move Data from multiple columns to 2 columns
Is there always an even number of teams?
Re: Move Data from multiple columns to 2 columns
Quote from KjBox;784587Is there always an even number of teams?
No but my sheet will put in a BYE instead of a letter, so 7 teams = 7 rounds as below
[TABLE="width: 583"]
[tr][td]Round
[/td][td]A
[/td][td]B
[/td][td]C
[/td][td]D
[/td][td]E
[/td][td]F
[/td][td]G
[/td][td]Bye
[/td][/tr][tr][td]Rnd 1
[/td][td]Bye
[/td][td]G
[/td][td]F
[/td][td]E
[/td][td]D
[/td][td]C
[/td][td]B
[/td][td]A
[/td][/tr][tr][td]Rnd 2
[/td][td]C
[/td][td]Bye
[/td][td]A
[/td][td]G
[/td][td]F
[/td][td]E
[/td][td]D
[/td][td]B
[/td][/tr][tr][td]Rnd 3
[/td][td]E
[/td][td]D
[/td][td]Bye
[/td][td]B
[/td][td]A
[/td][td]G
[/td][td]F
[/td][td]C
[/td][/tr][tr][td]Rnd 4
[/td][td]G
[/td][td]F
[/td][td]E
[/td][td]Bye
[/td][td]C
[/td][td]B
[/td][td]A
[/td][td]D
[/td][/tr][tr][td]Rnd 5
[/td][td]B
[/td][td]A
[/td][td]G
[/td][td]F
[/td][td]Bye
[/td][td]D
[/td][td]C
[/td][td]E
[/td][/tr][tr][td]Rnd 6
[/td][td]D
[/td][td]C
[/td][td]B
[/td][td]A
[/td][td]G
[/td][td]Bye
[/td][td]E
[/td][td]F
[/td][/tr][tr][td]Rnd 7
[/td][td]F
[/td][td]E
[/td][td]D
[/td][td]C
[/td][td]B
[/td][td]A
[/td][td]Bye
[/td][td]G
[/td][/tr]
[/TABLE]
Re: Move Data from multiple columns to 2 columns
Change the code to this
Option Explicit
Sub CreateRounds()
Dim x, y, i As Integer, ii As Integer, iii As Integer
With Sheet1
x = .Cells(7, 3).Resize(.[d3], .[d3] + 1).Value
ReDim y(1 To (.[d3] - 1) * (.[d3] / 2), 1 To 3)
End With
iii = 1
For i = 2 To UBound(x, 1)
y(iii, 1) = x(i, 1)
For ii = 2 To UBound(x, 2) Step 2
y(iii, 2) = x(i, ii): y(iii, 3) = x(i, ii + 1)
iii = iii + 1
Next
Next
With Sheet2.Cells(2, 2)
.CurrentRegion.Clear
.Resize(UBound(y, 1), 3) = y
End With
Application.Goto Sheet2.[a1], 1
End Sub
Display More
Re: Move Data from multiple columns to 2 columns
RjBox, the issue with the missing round is now fixed.... Thanks. But the odd number of teams isn't, I added the odd example below (7 teams = 7 rounds..... But 8 columns)... Sorry to be a pain!!
Re: Move Data from multiple columns to 2 columns
This should cover odd and even numbers of Teams.
Option Explicit
Sub CreateRounds()
Dim x, y, i As Integer, ii As Integer, iii As Integer
x = Cells(7, 3).Resize([d3] + [d3] Mod 2, ([d3] + [d3] Mod 2) + 1).Value
ReDim y(1 To (([d3] + [d3] Mod 2) - 1) * (([d3] + [d3] Mod 2) / 2), 1 To 3)
iii = 1
For i = 2 To UBound(x, 1)
y(iii, 1) = x(i, 1)
For ii = 2 To UBound(x, 2) Step 2
y(iii, 2) = x(i, ii): y(iii, 3) = x(i, ii + 1)
iii = iii + 1
Next
Next
With Sheet2.Cells(2, 2)
.CurrentRegion.Clear
.Resize(UBound(y, 1), 3) = y
End With
Application.Goto Sheet2.[a1], 1
End Sub
Display More
Re: Move Data from multiple columns to 2 columns
Excellent...... Works perfect..... Thanks for all the help :thumbcoo:
Don’t have an account yet? Register yourself now and be a part of our community!