我正在制作代码，以便从新列表中的数据库中复制数据。这样做的目的是在另一个程序的.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
答案 0 :(得分：0)
您可以调整并使用此代码：
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")
运行它，您将获得最终的数据安排
答案 1 :(得分：0)
我希望我没有过度杀戮，但是你的帖子为我提出了一个灯泡，因为我想要定义并使用 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