将 headers 行从组下移动到组之前的行

Question

我对 VBA 编程还很陌生，我的小公司已经有一个项目要处理。这是我的问题：

我们从 ERP 软件导出项目数据，客户希望能够使用公式编辑 Excel 文件中的数据。

问题是，"Project titles" 以某种方式位于 "Project positions" 之下。我试图在打印屏幕中更好地描述它。红框显示 "Project Titles"

我想上传图片，但是我的口碑还不够好（第一次post）

我会放一个 Imgur Link 在这里：http://i.imgur.com/ZKAY5Jz.png

是否可以使用 VBA 移动整行？问题是：仓位没有定义数量。因此，有必要使用一些 "marks"，例如 [x] 和 [ ]，我已放入 "IST" 列。

希望您能理解我的问题所在。

Answer 1

如果我没理解错的话，你要调出工程线。

这里有一些可能对您有帮助的东西（它假设每个 行的项目在第一列 上都是空的，并且数据从第 3 行开始（这里很容易更改）你的 sheet) :

Sub Faddi()
    Dim FirstDataRow As Integer, _
        LastRow As Integer, _
        RowToCopy As Integer, _
        RowToPaste As Integer

    FirstDataRow = 3

    With ActiveSheet
        LastRow = .Rows(.Rows.Count).End(xlUp).Row
        RowToCopy = .Cells(FirstDataRow, 1).End(xlDown).Row + 1

        'Insert the first row just under headers
        .Rows(RowToCopy).Copy
        .Rows(FirstDataRow).Insert Shift:=xlDown

        'Loop to find each other row to transfer
        Do While RowToCopy <= LastRow
            RowToPaste = RowToCopy
            RowToCopy = .Cells(RowToCopy + 1, 1).End(xlDown).Row + 1
            .Rows(RowToCopy).Copy Destination:=.Rows(RowToPaste)
        Loop
        'Delete last copied row to clean the file
        .Rows(RowToPaste).Delete
    End With
End Sub

Answer 2

谢谢大家的帮助。我找到了解决我的问题的方法，它似乎工作得很好。

Sub Finde_Die_Zelle()
Dim FindString As String
Dim Rng As Range
Dim lastRow As Long
Dim Runs As Long
Runs = 1
FindString = "[x]"
With Sheets("Tabelle1").Range("O:O")
    Set Rng = .Find(What:=FindString, _
                    After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False)
    If Not Rng Is Nothing Then
        Application.Goto Rng, True
    Else
        MsgBox "Fertig 1"
    End If
End With
ActiveCell.Value = "[o]"
ActiveCell.Offset(1).EntireRow.Insert
'ActiveCell.EntireRow.Copy
'Tabelle2.Range("A1").PasteSpecial
lastRow = Tabelle1.Range("F" & Rows.Count).End(xlUp).Row
'Do While Durchlaufe <> lastRow
FindString = "[  ]"
With Sheets("Tabelle1").Range("o:o")
Set Rng = .Find(What:=FindString, _
                    After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
    If Not Rng Is Nothing Then
        Application.Goto Rng, True
    Else
        MsgBox "Fertig 2"
    End If
    ActiveCell.Value = "[x]"
    ActiveCell.EntireRow.Copy
End With
FindString = "[o]"
With Sheets("Tabelle1").Range("O:O")
    Set Rng = .Find(What:=FindString, _
                    After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
    If Not Rng Is Nothing Then
        Application.Goto Rng, True
    Else
        MsgBox "Fertig 3"
    End If
End With
ActiveCell.Value = ""
ActiveCell.Offset(1).EntireRow.PasteSpecial
Runs = Runs + 1
FindString = "[x]"
With Sheets("Tabelle1").Range("O:O")
    Set Rng = .Find(What:=FindString, _
                    After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False)
    If Not Rng Is Nothing Then
        Application.Goto Rng, True
    Else
        MsgBox "Fertig 4"
    End If
End With
ActiveCell.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
ActiveCell.Value = "[x]"
'Loop
End Sub

我知道它可能看起来不那么专业，但这对我有用:) 再次感谢大家的投入

将 headers 行从组下移动到组之前的行

Move headers rows from under group to row just before group

excel

vba

position

row