Excel - Categorize table by column - excel

I currently have this table:
And I would like to categorize it by the last column so it appears as such:
I thought this might be doable with pivot tables or something but it doesn't seem to. I've also tried using a slicer but that doesn't give the desired effect (just hides and unhides rows). This seems like a common and simple enough thing to want to do but I can't seem to figure it out.
Edit:
I don't really want to just recreate the table in the image because the table won't be properly sortable or searchable (since the 'header' rows describing the category will get sorted improperly and come up in the search), I just want it displayed similarly to the image.
Table data:
| Armor | Cost | AC | Strength Requirement | Stealth | Weight | Class |
|-----------------|---------|----|----------------------|--------------|--------|--------------|
| Padded | 5 gp | 11 | — | Disadvantage | 8 lb | Light Armor |
| Leather | 10 gp | 11 | — | — | 10 lb | Light Armor |
| Studded leather | 45 gp | 12 | — | — | 13 lb | Light Armor |
| Hide | 10 gp | 12 | — | — | 12 lb | Medium Armor |
| Chain shirt | 50 gp | 13 | — | — | 20 lb | Medium Armor |
| Scale mail | 50 gp | 14 | — | Disadvantage | 45 lb | Medium Armor |
| Breastplate | 400 gp | 14 | — | — | 20 lb | Medium Armor |
| Half plate | 750 gp | 15 | — | Disadvantage | 40 lb | Medium Armor |
| Ring mail | 30 gp | 14 | — | Disadvantage | 40 lb | Heavy Armor |
| Chain mail | 75 gp | 16 | 13 | Disadvantage | 55 lb | Heavy Armor |
| Splint | 200 gp | 17 | 15 | Disadvantage | 60 lb | Heavy Armor |
| Plate | 1500 gp | 18 | 15 | Disadvantage | 65 lb | Heavy Armor |
| Shield | 10 gp | +2 | — | — | 6 lb | Shield |

You can create your own lookup as follows:
Option Explicit
Public outputRow As Long
'VBE > Tools > references > tick MS HTML Object Library, MS XML
Public Sub Main()
outputRow = 0
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Output") ''change as appropriate
ws.Cells.ClearContents
GetTables ws
AddKeys ws, 1
ws.Cells.Columns.AutoFit
ws.Columns("A:G").NumberFormat = "#"
End Sub
Public Sub GetTables(ByVal ws As Worksheet)
Dim http As New XMLHTTP60, html As New HTMLDocument, arr() As Variant 'XMLHTTP60 This will vary according to your Excel version
arr = Array("Currency", "Armor", "Selling Treasure", "Armor", "Weapons", _
"Adventuring Gear", "Tools", "Mounts and Vehicles", "Trade Goods", "Expenses")
Dim i As Long
For i = LBound(arr) To UBound(arr)
DoEvents
With http
.Open "GET", ConstructURL(LCase$(arr(i))), False
.send
html.body.innerHTML = .responseText
End With
PrintTables html, ws
Next i
End Sub
Public Sub PrintTables(ByVal html As HTMLDocument, ByVal ws As Worksheet)
Dim rng As Range, tbl As HTMLTable, currentRow As Object, currentColumn As Object, i As Long, counter As Long
For Each tbl In html.getElementsByTagName("Table")
counter = counter + 1
outputRow = outputRow + 1
Set rng = ws.Range("B" & outputRow)
rng.Offset(, -1) = "Table " & counter
For Each currentRow In tbl.Rows
For Each currentColumn In currentRow.Cells
rng.Value = currentColumn.outerText
Set rng = rng.Offset(, 1)
i = i + 1
Next currentColumn
outputRow = outputRow + 1
Set rng = rng.Offset(1, -i)
i = 0
Next currentRow
Next tbl
End Sub
Public Function ConstructURL(ByVal item As String) As String
ConstructURL = "https://dnd5e.info/equipment/" & item
End Function
Public Sub AddKeys(ByVal ws As Worksheet, Optional ByVal targetColumn As Long = 1)
Dim loopColumn As Range, rng As Range
Set loopColumn = ws.UsedRange.Columns(targetColumn)
Dim cat As String
For Each rng In loopColumn.Cells
If InStr(1, rng.Text, "Table") > 0 Then
cat = rng.Offset(, 1)
End If
If Not IsEmpty(rng.Offset(, 1)) And Not IsEmpty(rng.Offset(, 2)) Then
If IsEmpty(rng) And Not IsEmpty(rng.Offset(, 2)) Then
rng = cat & rng.Offset(, 1)
End If
If IsEmpty(rng) And IsEmpty(rng.Offset(, 2)) Then
rng = cat & rng.Offset(, 1)
End If
End If
Next rng
End Sub
Output:
Note column A has an unique key that you can use to lookup an item. You will however need to know which column you are interested in, though again you could match on the column header. You can tidy this up but is already suitable for a unique lookup for a given item.

Related

Macro stops prematurely

Macro to keep on going to the next cell till the value doesn't match and for all the similar values, subtract the values from the bottom most row
Essentially my data is like this (There is only one buy for each name and it is the bottom most cell)
Name | Transaction.Type | Amount | Remaining (what macro needs to do)
Name1 | Sell | 5 | 15 (20-5)
Name1 | Sell | 10 | 10 (20-10)
Name1 | Sell | 15 | 5 (20-15)
Name1 | Buy | 20 |
Name2 | Sell | 25 | 5
Name2 | Buy | 30 |
So far my macro looks like
Dim sline As Integer
Dim eline As Integer
Dim rng As Range
Dim lastrow(1 To 3) As Long
Application.DisplayAlerts = False
With Worksheets("Testing Data 2")
lastrow(1) = .Cells(Rows.Count, "A").End(xlUp).Row
End With
For i = 2 To 4151
If Worksheets("Testing Data 2").Range("A" & i) <> Worksheets("Testing Data 2").Range("A" & i).Offset(1, 0) Then
eline = i
Worksheets("Testing Data 2").Range(":C" & eline)
'struggling to go from here
End If
Next i
Application.DisplayAlerts = True
You can do this without VBA with the understanding that each Name only has one instnace of Buy
=SUMIFS(C:C,A:A,A3,B:B,"Buy")-C2 'Drag down as needed

Look for last column that has a specific value

I have a file with 8+ "Sales" columns spreading throughout my worksheet. I tried the following code to do: If any Sales cells have "Title Transfer" then the 51st column would have an "x".
Option Explicit
Public Const colTTransfer As Long = 51
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastColumn As Long
Dim counter As Long
lastColumn = Me.Cells(1, Me.Columns.Count).End(xlToLeft).Column
If Me.Cells(1, Target.Column).Value = "Sales" Then
For counter = 1 To lastColumn
If Me.Cells(Target.Row, counter).Value = "Title Transfer" Then
Me.Cells(Target.Row, colTTransfer).Value = "x"
End If
Next counter
End If
End Sub
However, I realised there was more to my original purpose and the above codes weren't flexible. My codes check any Sales cells that are Title Transfer but they didn't reflect the changes of other Sales cells within the same rows.
For example, if a cell in my 1st Sales column has Title Transfer then the 51st column would return an x. And if the cell in the 2nd Sales column within the same row has a different value, e.g. Green, the x in the 51st column should be removed (which my codes can't)
So I'm wondering if there is a way to only return x for the last Sales column that has Title Transfer?
For example, assuming these events happen in the same row where:
1st Sales column has Green and 51st column remain blank
2nd Sales column has Title Transfer and 51st column has x
3rd Sales column has Rollup and 51st column turns blank
4th Sales column has Red and 51st column remains the same
5th Sales column has Title Transfer and 51st column now has x
and so on
This what my data looks like:
| Title | Engine Family | Market Segment | Customer | Engine Model | S/N | Build Spec | ACTL.FINISH | Sales Order | Item | Committed Date | EPS Date | Target | Sales | Production | Day 1 | Status | Sales | Production | Day 2 | Status | Sales | Production | Day 3 | Status | Sales | Production | Day 4 | Status | Sales | Production | Day 5 | Status | Sales | Production | Day 6 | Status | Sales | Production | Day 7 | Status | Sales | Production | Day 8 | Status | Status | Comments | MB51 Shipped | FPS? | Plant | Title Transfer |
|--------|------------------|----------------|----------|--------------|-----|------------|-------------|-------------|-------|----------------|------------|--------|-------|------------|-------|--------|----------------|------------|-------|--------|--------|------------|-------|--------|-------|------------|-------|--------|----------------|------------|-------|--------|--------|------------|-------|--------|----------------|------------|-------|--------|-------|------------|-------|--------|--------|----------|--------------|------|-------|----------------|
| Rollup | PS | APU | HAC | T-62T-46C12 | 1 | BS1 | 0000-00-00 | 0 | 0 | 2019/12/31 | 2019/12/31 | | Green | | | | Title Transfer | | | | Rollup | | | | Red | | | | Title Transfer | | | | Rollup | | | | Title Transfer | | | | | | | | | | | | | x |
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
Link to sample
Please advise how I can make it work that way. Any help is highly appreciated. Thank you
You just need to move the Title Transfer field update to the end of the loop and evaluate each Sales column to the end. The updated code should resolve that.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < colTTransfer Then
If Trim(UCase(Me.Cells(1, Target.Column).Value)) = "SALES" Then
Dim lastColumn As Long
Dim counter As Long
Dim rowIsTitleTransfer As Boolean
lastColumn = Me.Cells(1, Me.Columns.Count).End(xlToLeft).Column
rowIsTitleTransfer = False
' loop
For counter = 1 To lastColumn
If Trim(UCase(Me.Cells(1, Target.Column).Value)) = "SALES" Then
rowIsTitleTransfer = Me.Cells(Target.Row, counter).Value = "Title Transfer"
End If
Next counter
' assign title transfer column
If rowIsTitleTransfer Then
Me.Cells(Target.Row, colTTransfer).Value = "x"
Else
Me.Cells(Target.Row, colTTransfer).Value = ""
End If
End If
End If
End Sub
I found my answer. Still, thank you for everyone's help
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, r1 As Range, lastColumn As Long, counter As Long
Dim MaxCol As Variant, rg As Range, j As Long
If Not Intersect(Target, Range("N:AP")) Is Nothing And Target.Column Mod 4 = 2 Then
Set r = Intersect(Target, Cells(1, 1).CurrentRegion, Columns(Target.Column).Resize(, 3))
Call DoCells(r)
End If
' Get last column based on first row
lastColumn = Me.Cells(1, Me.Columns.Count).End(xlToLeft).Column
If Me.Cells(1, Target.Column).Value = "MB51 Shipped" Then
For counter = 1 To lastColumn
If (Me.Cells(1, counter).Value = "Sales" Or Me.Cells(1, counter).Value = "Production") And IsEmpty(Me.Cells(Target.Row, counter).Value) Then
Me.Cells(Target.Row, counter).Value = "Rollup"
End If
Next counter
End If
If Not Intersect(Target, Range("N:AP")) Is Nothing And Target.Column Mod 4 = 2 Then
If Target.CountLarge > 1 Then Exit Sub
Set rg = Range("N" & Target.Row & ":AP" & Target.Row)
MaxCol = 0
For j = Columns("AP").Column To Columns("N").Column Step -4
If Cells(Target.Row, j) <> "" Then
If j > MaxCol Then MaxCol = j
End If
Next
If MaxCol Mod 4 = 2 Then
If Cells(Target.Row, MaxCol).Value = "Title Transfer" Then
Cells(Target.Row, 51).Value = "x"
Else
Cells(Target.Row, 51).Value = ""
End If
End If
End If
End Sub

Show data from a spreadsheet according to the selected data in another spreadsheet

Probably this question is very rookie, but not really used to play a lot with Excel, anyway here I go.
I have 2 spreadsheets: A and B
In the spreadsheet "A" have the following info:
+----------+--------+-------+------+
| DATE | CODE | CORRL | CAPA |
+----------+--------+-------+------+
| 01/03/17 | 110104 | 5 | 28 |
| 01/03/17 | 110104 | 7 | 30 |
| 01/03/17 | 810107 | 5 | 30 |
+----------+--------+-------+------+
and in the spreadsheet "B" the following info:
+----------+--------+-------+--------+
| DATE | CODE | CORRL | SN |
+----------+--------+-------+--------+
| 01/03/17 | 110104 | 5 | 182694 |
| 01/03/17 | 110104 | 5 | 571394 |
| 01/03/17 | 110104 | 7 | 298435 |
| 01/03/17 | 110104 | 7 | 205785 |
| 01/03/17 | 810107 | 5 | 234519 |
| 01/03/17 | 810107 | 5 | 229787 |
+----------+--------+-------+--------+
So what I need is when I move through the records of the spreadsheet "A" only the records with the same value of DATE, CODE and CORRL in the spreadsheet "B" are shown
Example:
If I'm positioned in the 1st row of the spreadsheet "A" in the spreadsheet "B" only the first 2 records must be shown, that is:
+-----------+---------+--------+--------+
| DATE | CODE | CORRL | SN |
+-----------+---------+--------+--------+
| 01/03/17 | 110104 | 5 | 182694 |
| 01/03/17 | 110104 | 5 | 571394 |
+-----------+---------+--------+--------+
and so on
Thanks
I have to say, this is one of the more different requests that I've seen for Excel functionality.
I think I have something for you.
Firstly, if you're not familiar with the VBA editor then you can access it by pressing Alt + F11. Another way to access it is from the Developer tab in your ribbon, which is hidden by default. To unhide it, change the ribbon to include it.
From there you can get to the VBA editor as well as run macros.
From within there, add the following code ...
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lngRow As Long, lngCol As Long, strDate As String, strCode As String, strCorrl As String
Dim strKey As String, strSlaveKey As String, i As Long
If objSlaveSheet Is Nothing Then Exit Sub
objSlaveSheet.Rows.EntireRow.Hidden = True
objSlaveSheet.Rows(1).Hidden = False
If Target.Cells(1, 1).Row > 1 Then
With Target.Worksheet
strDate = .Cells(Target.Row, 1)
strCode = .Cells(Target.Row, 2)
strCorrl = .Cells(Target.Row, 3)
strKey = strDate & "_" & strCode & "_" & strCorrl
End With
' Now loop through all of the cells in the slave workbook.
' Start at the second row because the first has a header.
With objSlaveSheet
For lngRow = 2 To .Rows.Count
strSlaveKey = ""
For i = 1 To 3
strSlaveKey = strSlaveKey & "_" & .Cells(lngRow, i)
Next
strSlaveKey = Mid(strSlaveKey, 2)
If strSlaveKey = "__" Then Exit For
If strSlaveKey = strKey Then
.Rows(lngRow).Hidden = False
End If
Next
.Activate
.Cells(1, 1).Select
End With
End If
End Sub
... into the worksheet where you want to trigger the selection from, this is your worksheet A.
Also in workbook A, create a new Module in the VBA editor and paste the following code ...
Public objSlave As Workbook
Public objSlaveSheet As Worksheet
Public Sub SelectSlaveBook()
Dim objDlg As FileDialog, strFile As String, strSlaveSheetName As String
strSlaveSheetName = "Sheet1"
Set objDlg = Application.FileDialog(msoFileDialogOpen)
objDlg.Show
If objDlg.SelectedItems.Count > 0 Then
strFile = objDlg.SelectedItems(1)
Set objSlave = Application.Workbooks.Open(strFile, False, True)
Set objSlaveSheet = objSlave.Worksheets(strSlaveSheetName)
ThisWorkbook.Activate
End If
End Sub
... before moving on, make sure you change the value of strSlaveSheetName to be the name of the sheet where your data is in your "Slave" workbook (B).
Finally in worksheet A, add the following code into the ThisWorkbook object ...
Private Sub Workbook_Open()
SelectSlaveBook
End Sub
... now close the master workbook (in your case, workbook A) and open it again.
You will be prompted for the location of the "Slave" workbook (workbook B).
Once you've given that location, select what you want to select and all things held constant, it should work for you.
Of course, if it needs tweaks to suit your exact requirement, that's always possible.
I hope it works for you.

Extract unique values from a range in excel while disregarding specific values

I originally had an Excel spreadsheet which was used to record values of JOB LOT IDs (>10000). I used the following array formula -
=INDIRECT(TEXT(MIN(IF(($C$3:$S$52<>"")*(COUNTIF($V$3:V3,$C$3:$S$52)=0),ROW($3:$52)*100+COLUMN($C$S),7^8)),"R0C00"),)&""
Data:
| pallet | Lot# | Lot# | Lot# | Lot# | Lot# |
|-------- |------- |------- |-------- |------- |-------- |
| 1 | 12345 | 12346 | 12345 | 12347 | 123456 |
| 2 | 12345 | 12346 | 12348 | 12348 | 12343 |
| 3 | 12345 | 12347 | 123456 | 12348 | 12348 |
This worked fine if the cells in that range all represented the JOB LOT IDs.
It would record the unique LOT #'s as I copied this into the result range and coupled with the counting formula
(IF(LEN(V4)>0,COUNTIF($C$3:$S$52,V4),"")
in the adjacent cell. It returned:
Unique
Value Count
______ _____
12345 4
12346 2
12347 2
123456 2
12348 4
12343 1
Unfortunately, the scope of the job and spreadsheet changed such that the spreadsheet needed to include columns before each JOB LOT cell to record the Case# of the JOB LOT.
What I need help with is figuring out how to disregard the case# data, which will always be between 1 and 451, and only count the unique JOB LOT IDs, which will always be > 100000. Resulting in only the unique list of Job Numbers. Using the same array formula with the added column for Case#, the Case Numbers are also listed, when they are not needed or wanted.
| pallet | case# | Lot# | case# | Lot# | case# | Lot# | case# | Lot# | case# | Lot# |
|-------- |------- |------- |------- |------- |------- |-------- |------- |------- |------- |-------- |
| 1 | 1 | 12345 | 45 | 12346 | 356 | 12345 | 6 | 12347 | 7 | 123456 |
| 2 | 3 | 12345 | 35 | 12346 | 212 | 12348 | 23 | 12348 | 200 | 12343 |
| 3 | 54 | 12345 | 34 | 12347 | 450 | 123456 | 345 | 12348 | 367 | 12348 |
The result is
Unique
Value Count
______ _____
12345 4
45 1
12346 2
356 1
6 1
12347 2
7 1
123456 2
35 1
212 1
12348 4
23 1
200 1
12343 1
34 1
450 1
345 1
367 1
Any Suugestions?
Thanks.
You could use a dictionary to hold the unique Lot# as keys and add one to the value associated with this key each time the key is encountered again.
The data is read in from the sheet, from column C to the right most column, into an array, arr. arr is looped only looking at every other column i.e. the Lot# columns. The contents of the dictionary i.e. the unique Lot# (Keys) and count of them (Items), are written out to sheet2.
It assumes your data starts in A1 and has the layout given in the question.
Option Explicit
Public Sub GetUniqueValueByCounts()
Dim arr(), i As Long, j As Long, dict As Object, lastColumn As Long, lastRow As Long
Const NUMBER_COLUMNS_TO_SKIP = 2
Set dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
If lastColumn < 3 Or lastRow < 2 Then Exit Sub
arr = .Range(.Cells(2, 3), .Cells(lastRow, lastColumn)).Value
For i = LBound(arr, 2) To UBound(arr, 2) Step NUMBER_COLUMNS_TO_SKIP
For j = LBound(arr, 1) To UBound(arr, 1)
If arr(j, i) <> vbNullString Then
dict(arr(j, i)) = dict(arr(j, i)) + 1
End If
Next
Next
End With
With Worksheets("Sheet2")
.Range("A1").Resize(dict.Count, 1) = Application.WorksheetFunction.Transpose(dict.Keys)
.Range("B1").Resize(dict.Count, 1) = Application.WorksheetFunction.Transpose(dict.Items)
End With
End Sub
Ordered results:
You can use a sortedList to get ordered results though you lose the nice .Keys and .Items methods of generating arrays in one go to write to the sheet.
Option Explicit
Public Sub GetUniqueValueByCounts()
Dim arr(), i As Long, j As Long, dict As Object, lastColumn As Long, lastRow As Long, list As Object
Const NUMBER_COLUMNS_TO_SKIP = 2
Set dict = CreateObject("Scripting.Dictionary")
Set list = CreateObject("System.Collections.SortedList")
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
If lastColumn < 3 Or lastRow < 2 Then Exit Sub
arr = .Range(.Cells(2, 3), .Cells(lastRow, lastColumn)).Value
For i = LBound(arr, 2) To UBound(arr, 2) Step NUMBER_COLUMNS_TO_SKIP
For j = LBound(arr, 1) To UBound(arr, 1)
If arr(j, i) <> vbNullString Then
With list
If Not .contains(arr(j, i)) Then
list.Add arr(j, i), 1
Else
list(arr(j, i)) = list(arr(j, i)) + 1
End If
End With
End If
Next
Next i
End With
With Worksheets("Sheet2")
For j = 0 To list.Count - 1
.Cells(j + 1, 1) = list.GetKey(j)
.Cells(j + 1, 2) = list.GetByIndex(j)
Next
End With
End Sub

Excel convert columns to new rows

I have a table that looks like this:
| A | B | C | D |
+-------+------------+------------+------------+
1 | Name | Language 1 | Language 2 | Language 3 |
+=======+============+============+============+
2 | John | English | Chinese | Spanish |
3 | Wendy | Chinese | French | English |
4 | Peter | Spanish | Chinese | English |
And I want to generate a table that has only one language column. The other two language columns should become new rows like this:
| A | B |
+-------+----------+
1 | Name | Language |
+=======+==========+
2 | John | English |
3 | John | Chinese |
4 | John | Spanish |
5 | Wendy | Chinese |
6 | Wendy | French |
7 | Wendy | English |
8 | Peter | Spanish |
9 | Peter | Chinese |
10 | Peter | English |
I understand this will probably will need a macro or something. If anybody point me in the right direction it would me much appreciate. I am not very familiar with VBA or the Excel object model.
This will do the trick. It is also dynamic supports as many language columns as you want with as many languages per person.
Assumes the data is formatted as per the example:
Sub ShrinkTable()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
Dim newSht As Worksheet
Set newSht = Sheets.Add
With newSht
.Cells(1, 1).Value = "Name"
.Cells(1, 2).Value = "Column"
Dim writeRow As Double
writeRow = 2
Dim row As Double
row = 2
Dim col As Integer
Do While True
col = 2
Do While True
If data(row, col) = "" Then Exit Do 'Skip Blanks
'Name
.Cells(writeRow, 1).Value = data(row, 1)
'Language
.Cells(writeRow, 2).Value = data(row, col)
writeRow = writeRow + 1
If col = maxCols Then Exit Do 'Exit clause
col = col + 1
Loop
If row = maxRows Then Exit Do 'exit cluase
row = row + 1
Loop
End With
End Sub
Messy but should work:
For Each namething In Range("A1", Range("A1").End(xlDown))
Range("A1").End(xlDown).Offset(1, 0) = namething.Value
Range("A1").End(xlDown).Offset(0, 1) = namething.Offset(0, 2)
Range("A1").End(xlDown).Offset(1, 0) = namething.Value
Range("A1").End(xlDown).Offset(0, 1) = namething.Offset(0, 3)
namething.Offset(0, 2) = ""
namething.Offset(0, 3) = ""
Next
Then just sort
The following formula should work. The data in sheet2 would always reflect the data on sheet1 so you wouldn't have to re-run a macro to create a new list.
That being said, using a macro to generate it is probably a better choice as it would allow more flexability should you need to add a 4th language or something at a later date.
In Sheet2!A2
=INDIRECT("Sheet1!A"&ABS(INT((ROW()+1)/3))+1)
In Sheet2!B2
=INDIRECT("Sheet1!"&IF(ABS(INT((ROW()+1)/3)-(ROW()+1)/3)=0,"B",IF(ABS(INT((ROW()+1)/3)-(ROW()+1)/3)=(1/3),"C","D"))&ABS(INT((ROW()+1)/3))+1)
Add the column titles in A1 and B1 then autofill the formula down the sheet.

Resources