Copy Range and Sort the copied cells - vba

Question

I'm making a code in order to copy data from a database in a new list. This with the purpose of using this data in a .txt export file in another program.
I have a large list with names and data next to it. And I would like to copy the names with the associated data in a new workbook. This data also needs to be sorted in 'depth' in order to get the result that I need for the export file.
I hope somebody can help me with this. At this moment I managed to get a list of the names and the start and end row of each name in a new workbook. I think this helps me with getting the data sorted.
Now I want to expand this code so that I can copy the data that I need.
I included a picture where you can see how my database looks. This is indicated in the black square. And in the red square you see how I want the result list to look like.
I hope somebody can help me with this!
Database and Result
This is the code that I have until now:
Option Explicit
Sub RowCount()
Dim Oldstatusbar As Boolean
Dim DOF As Integer, Counter As Integer, Row_Copied As Integer
Dim CurrentMin As Long, StartRow As Long, StartColumn As Long
Dim OutputColumn As Long, OutputRow As Long
Dim Borehole As String, Start_Row As String, End_Row As String, Output As String
Dim CurrentName As String
Dim rng As RANGE, Cell As RANGE, brh As RANGE
Dim wbMain As Workbook, wbWellsRowCount As Workbook
Dim wsLog As Worksheet, wsSheet1 As Worksheet, wsSheet2 As Worksheet
Dim HCdatabase2 As Variant
Oldstatusbar = Application.DisplayStatusBar
Set wbMain = Workbooks("HCdatabase2.xlsm")
Set wsLog = wbMain.Sheets("Log")
DOF = 1
Counter = 1
Row_Copied = 0
wsLog.Select
StartColumn = 1
StartRow = 1
wsLog.Cells(StartRow + DOF, StartColumn).End(xlDown).Select
Set rng = wsLog.RANGE(wsLog.Cells(StartRow + DOF, StartColumn), wsLog.Cells(StartRow + DOF, StartColumn).End(xlDown))
CurrentName = wsLog.Cells(StartRow + DOF, StartColumn).Value
CurrentMin = Cells(StartRow + DOF, StartColumn).Row
Set wbWellsRowCount = Workbooks.Add
wbWellsRowCount.SaveAs "H:\Petrel\2016 Youri Kickken - Stage - HC Shows\VBA\Code Set-up\VBA-DATABASE\wbWellsRowCount.xls"
Set wsSheet1 = wbWellsRowCount.Sheets("Sheet1")
wsSheet1.Select
OutputColumn = 1
OutputRow = DOF + 1
wsSheet1.Cells(OutputRow, OutputColumn).Value = CurrentName
wsSheet1.Cells(OutputRow, OutputColumn + 1).Value = CurrentMin
wsSheet1.Cells(1, 1).Name = "Borehole"
wsSheet1.Cells(1, 2).Name = "Start_Row"
wsSheet1.Cells(1, 3).Name = "End_Row"
wsSheet1.Cells(1, 4).Name = "Output"
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
Set wsSheet2 = wbWellsRowCount.Sheets("Sheet2")
For Each Cell In rng
If Cell.Value <> CurrentName Then
wsSheet1.Cells(OutputRow, OutputColumn + 2).Value = Cell.Row - 1
CurrentName = Cell.Value
CurrentMin = Cell.Row
OutputRow = OutputRow + 1
wsSheet1.Cells(OutputRow, OutputColumn).Value = CurrentName
wsSheet1.Cells(OutputRow, OutputColumn + 1).Value = CurrentMin
wsSheet1.Cells(Counter + DOF, "D").Value = Counter
Counter = Counter + 1
End If
Next Cell
Set Cell = rng.End(xlDown)
wsSheet1.Cells(OutputRow, OutputColumn + 2).Value = Cell.Row
wsSheet1.Cells(Counter + DOF, "D").Value = Counter
End If
Next Cell
wbWellsRowCount.Close True
RANGE("A1").Select
ActiveWindow.ScrollRow = RANGE("A1").Row
Application.ScreenUpdating = True
Application.DisplayStatusBar = Oldstatusbar
End Sub

Answer 1

you can adapt and use this code:
Option Explicit
Sub main()
With Workbooks("Data").Worksheets("Depths") '<--| change 'Workbooks("Data").Worksheets("Depths")' with your actual workbook and worksheet name
With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)) '<--| refer to column "A" cells from row 2 down to last non empty one
.Offset(.Rows.Count).value = .value '<--| duplicate names down column "A"
.Offset(.Rows.Count, 1).value = .Offset(, 3).value '<--| duplicate 2nd Depth column down 1st Depth column
.Offset(.Rows.Count, 4).value = .Offset(, 4).value '<--| duplicate Class_2 column down itself
.Offset(, 4).ClearContents '<--| clear original Class_2 column
.Offset(, 3).EntireColumn.Delete '<--| delete 2nd Depth column, no longer needed
With .Offset(, 1).Resize(2 * .Rows.Count) '<--|refer to Depth column (the only one remained)
If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(XlCellType.xlCellTypeBlanks).EntireRow.Delete '<--| delete empty values rows
End With
End With
With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 4) '<--| refer to all data: columns "A:D" from row 2 down to column "A" last non empty one
.Sort key1:=.Cells(1, 1), order1:=xlAscending, key2:=.Cells(1, 2), order2:=xlAscending, header:=xlNo, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal '<--| sort it!
End With
End With
End Sub
so that once you have your original data already copied in the final place as per your "Starting Point database" example, you just:
change Workbooks("Data").Worksheets("Depths") with your actual final place workbook and worksheet references
run it and you'll have the final data arrangement

Answer 2

I hope I didn't overkill it, but your post raised a light-bulb for me, as I thought of defining and using a cDepth Class.
The following Sub (your code, mostly) does the following things:
1) Scans the entire wsLog worksheet, and organizes the data in cDepth Class (array).
2) Sorts the Depths_Arr (from cDepth Class) according to Name and then by Depth).
3) Copies the data back (in my code I am copying the data to Columns H:K in the same worksheet) - you can modify the target easily.
Option Explicit
' Class Array CDates Variables to store all Series data
Public Current_Depth As CDepth
Public Depths_Arr() As CDepth
Sub RowCount()
Dim Oldstatusbar As Boolean
Dim DOF As Integer, Counter As Integer, Row_Copied As Integer
Dim CurrentMin As Long, StartRow As Long, StartColumn As Long
Dim OutputColumn As Long, OutputRow As Long
Dim Borehole As String, Start_Row As String, End_Row As String, Output As String
Dim CurrentName As String
Dim rng As Range, Cell As Range, brh As Range
Dim wbMain As Workbook, wbWellsRowCount As Workbook
Dim wsLog As Worksheet, wsSheet1 As Worksheet, wsSheet2 As Worksheet
Dim HCdatabase2 As Variant
Dim LastRow As Long, lRow As Long
Dim ClassIndex As Long
Oldstatusbar = Application.DisplayStatusBar
Set wbMain = Workbooks("HCdatabase2.xlsm")
Set wsLog = wbMain.Sheets("Log")
DOF = 1
StartColumn = 1
StartRow = 1
ClassIndex = 0
LastRow = wsLog.Cells(wsLog.Rows.Count, StartColumn).End(xlUp).Row
For lRow = StartRow + DOF To LastRow
Set Current_Depth = New CDepth
' organize data in Current_Depth array
With Current_Depth
If wsLog.Cells(lRow, 2) > 0 Then
.cName = wsLog.Cells(lRow, StartColumn)
.Depth = wsLog.Cells(lRow, StartColumn + 1)
.ClassVal = wsLog.Cells(lRow, StartColumn + 2)
.ClassType = 1
ReDim Preserve Depths_Arr(0 To ClassIndex)
Set Depths_Arr(ClassIndex) = Current_Depth
ClassIndex = ClassIndex + 1
Set Current_Depth = Nothing
End If
End With
Set Current_Depth = New CDepth
With Current_Depth
If wsLog.Cells(lRow, 4) > 0 Then
.cName = wsLog.Cells(lRow, StartColumn)
.Depth = wsLog.Cells(lRow, StartColumn + 3)
.ClassVal = wsLog.Cells(lRow, StartColumn + 4)
.ClassType = 2
ReDim Preserve Depths_Arr(0 To ClassIndex)
Set Depths_Arr(ClassIndex) = Current_Depth
ClassIndex = ClassIndex + 1
Set Current_Depth = Nothing
End If
End With
Next lRow
' variables for bubble-sort
Dim tmp_DepthArr As CDepth
Dim i, j As Long
' sort Depth array >> first by Name >> second by Depth
For i = LBound(Depths_Arr) To UBound(Depths_Arr) - 1
For j = i + 1 To UBound(Depths_Arr)
' first sort >> by Name
If Depths_Arr(i).cName > Depths_Arr(j).cName Then
Set tmp_DepthArr = Depths_Arr(i)
Set Depths_Arr(i) = Depths_Arr(j)
Set Depths_Arr(j) = tmp_DepthArr
Set tmp_DepthArr = Nothing
Exit For
End If
' second sort >> by Depth
If Depths_Arr(i).cName = Depths_Arr(j).cName And Depths_Arr(i).Depth > Depths_Arr(j).Depth Then
' switch position between cMilesones class array elements according to Plan Date
Set tmp_DepthArr = Depths_Arr(i)
Set Depths_Arr(i) = Depths_Arr(j)
Set Depths_Arr(j) = tmp_DepthArr
Set tmp_DepthArr = Nothing
End If
Next j
Next i
' copy sorted Depths Array back to sheet >> Modify target according to your needs
For i = LBound(Depths_Arr) To UBound(Depths_Arr)
wsLog.Cells(i + 2, StartColumn + 7) = Depths_Arr(i).cName
wsLog.Cells(i + 2, StartColumn + 8) = Depths_Arr(i).Depth
wsLog.Cells(i + 2, StartColumn + 8 + Depths_Arr(i).ClassType) = Depths_Arr(i).ClassVal
Next i
End Sub
The following cDepth Class is for storing the Table's data in an organized array with the following attributes:
Name, Depth, ClassVal and ClassType
CDepth Class code:
'private Attributes
Private pName As String
Private pDepth As Integer
Private pClassVal As Integer
Private pClassType As Integer
' --- Get/Let Methods ---
Public Property Get cName() As String
cName = pName
End Property
Public Property Let cName(value As String)
pName = value
End Property
Public Property Get Depth() As Integer
Depth = pDepth
End Property
Public Property Let Depth(value As Integer)
pDepth = value
End Property
Public Property Get ClassVal() As Integer
ClassVal = pClassVal
End Property
Public Property Let ClassVal(value As Integer)
pClassVal = value
End Property
Public Property Get ClassType() As Integer
ClassType = pClassType
End Property
Public Property Let ClassType(value As Integer)
pClassType = value
End Property