範囲をコピーしてコピーしたセルを並べ替えます

Question

データベースから新しいリストにデータをコピーするためのコードを作成しています。これは、このデータを別のプログラムの.txtエクスポートファイルで使用するためです。

名前とデータの横に大きなリストがあります。そして、新しいワークブックに関連付けられたデータとともに名前をコピーしたいと思います。このデータは、エクスポートファイルに必要な結果を得るために、'深さ'でソートする必要があります。

私は誰かがこれで私を助けることを願っています。この瞬間、新しいワークブックに名前のリストと各名前の最初と最後の行が表示されました。私はこれが、データをソートするのに役立つと思います。

今私は必要なデータをコピーできるようにこのコードを展開したいと思います。 私はあなたのデータベースの見た目を見ることができる画像を含んでいました。これは黒い四角で示されています。そして、赤い四角形の中に、結果リストをどのように見せたいかを見ています。 誰かが私を助けてくれることを願っています！ 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

があるでしょうが、 cDepthClassを定義して使用することを考えたとき、あなたのポストは私のために電球を持ち上げました。

次の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 

次cDepthClassは、次の属性を持つ組織化配列表のデータを格納するためのものである： 名前、深、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