在组之前将标题行从组下移到行

我对VBA编程颇为陌生，我已经有一个项目可以在我的小公司工作。 这是我的问题：

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

问题是，“项目标题”在某种程度上置于“项目位置”之下。 我试图在打印屏幕中更好地描述它。 红框显示“项目标题”

我想上传一张图片，但是我的声望还不够好（我的第一篇文章）

我会把Imgur链接放在这里： http : //i.imgur.com/ZKAY5Jz.png

用VBA移动整行的任何可能性？ 问题是：仓位没有定义的数量。 所以有必要使用一些“标记”，比如我在“IST”列中input的[x]和[ ] 。

我希望你能理解我的问题实际上是什么。

Answer 1

如果我理解得当，你想要提出项目的路线。

这里有一些可能对你有帮助的事情（假定每行项目在第一列是空的 ，而且数据从你的表格的第3行开始（在这里很容易修改）：

 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

谢谢大家的帮助。 我发现了一个解决scheme，似乎工作得很好。

 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 

我知道这可能不是专业，但这对我的作品:)谢谢大家的投入