Question

我正在制作代码，以便从新列表中的数据库中复制数据。这样做的目的是在另一个程序的.txt导出文件中使用这些数据。

我有一个包含名称和数据的大型列表。我想在新工作簿中复制带有相关数据的名称。此数据还需要在'depth'中排序，以获得导出文件所需的结果。

我希望有人可以帮助我。此时，我设法在新工作簿中获取每个名称的名称以及开始和结束行的列表。我认为这有助于我对数据进行排序。

现在我想扩展此代码，以便我可以复制我需要的数据。我添加了一张图片，您可以在其中查看我的数据库的外观。这在黑色方块中表示。在红色方块中，您可以看到我希望结果列表看起来如何。我希望有人可以帮助我！ Database and Result

这是我到目前为止的代码：

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

您可以调整并使用此代码：

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

以便根据“起点数据库”示例将原始数据复制到最终位置之后，您只需：

使用您的实际最终位置工作簿和工作表参考更改Workbooks("Data").Worksheets("Depths")
运行它，您将获得最终的数据安排

Answer 2

我希望我没有过度杀戮，但是你的帖子为我提出了一个灯泡，因为我想要定义并使用 cDepth Class。

以下Sub（主要是您的代码）执行以下操作：

1）扫描整个 wsLog 工作表，并在 cDepth 类（数组）中组织数据。

2）根据名称然后按深度对 Depths_Arr （来自cDepth Class）进行排序。

3）将数据复制回来（在我的代码中，我将数据复制到同一工作表中的列H：K ） - 您可以轻松修改目标。

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

以下 cDepth Class用于将Table的数据存储在具有以下属性的有组织数组中：名称，深度， ClassVal 和 ClassType

CDepth 类代码：

'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

复制范围并对复制的单元格进行排序

2 个答案: