Vba 筛选数据库并将数据拆分为表

我有一个数据库，有15个项目的状态更新。数据库每天更新，但并非所有项目都每天更新

我计划编写一个代码，根据项目过滤数据库，并将每个项目的所有更新合并到一个单独的表中

下面的代码成功地组合了所选项目的更新并将其粘贴到另一张图纸上，但问题是，由于它是一个循环，因此如果if statesmens为true，则每次都会多次复制项目名称。我想要的是关于如何仅复制项目名称1次并将其粘贴为表标题，然后粘贴该项目的所有相关更新的帮助

请注意，代码将重复15次，因为我有15个项目，但我下面的内容仅适用于project1，因此，如果您还知道如何循环此代码，而不是重新编写代码15次，例如：（project1、project2等）

---

您可以使用

project（）

数组，然后使用

For

循环输入列“U”中的所有值

代码

Option Explicit

Sub report()

Dim project() As String
Dim finalrow As Long, i As Long, j As Long

ReDim project(1 To 15)

With Sheet4
    For i = 1 To 15
        project(i) = Sheet4.Range("U" & i).Value
    Next i

    finalrow = .Range("A2000").End(xlUp).Row    

    '===== I think this is what you meant =====        
    ' Option 1: looping through each row and check it againt all elements inside project array    
    For i = 1 To finalrow
        For j = 1 To UBound(project)
            If .Cells(i, 1) = project(j) Then
                Sheet7.Range("A100").End(xlUp).Offset(1, 0) = project(j)

                .Range(.Cells(i, 2), .Cells(i, 8)).Copy
                Sheet7.Range("A100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
             End If                
        Next j
    Next i


    '===== Option 2: use the Match function to see if the value in Cells(i, 1) equals one of the =====
    ' elements inside project array
    For i = 1 To finalrow
        If Not IsError(Application.Match(.Cells(i, 1), project, 0)) Then ' <-- successful match
            j = Application.Match(.Cells(i, 1), project, 0) ' <-- get the element index inside the project array
            Sheet7.Range("A100").End(xlUp).Offset(1, 0) = project(j)

            .Range(.Cells(i, 2), .Cells(i, 8)).Copy
            Sheet7.Range("A100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
        End If
    Next i
End With    

End Sub

选项显式
次级报告（）
将项目（）设置为字符串
暗淡的结局如长，我如长，j如长
ReDim项目（1至15）
附页4
对于i=1到15
项目（i）=表4.范围（“U”和i）.值
接下来我
finalrow=.Range（“A2000”）.End（xlUp）.Row
我想这就是你的意思
'选项1：循环遍历每一行并在项目数组中的所有元素上检查它
对于i=1到最后一行
对于j=1至UBound（项目）
如果.Cells（i，1）=项目（j），则
表7.范围（“A100”）.结束（xlUp）.偏移量（1，0）=项目（j）
.Range（.Cells（i，2），.Cells（i，8））.Copy
表7.范围（“A100”）.结束（xlUp）.偏移量（1,0）.粘贴特殊XLPaste值和数字格式
如果结束
下一个j
接下来我
'====选项2：使用Match函数查看单元格（i，1）中的值是否等于=====
'项目数组中的元素
对于i=1到最后一行
如果不是IsError（Application.Match（.Cells（i，1），project，0）），那么“”为了避免重复项目名称，可以运行另一个宏。伪代码如下所示：

Sub HideRepeatedNames()
'presuming project names are in column1
for n=1 to lastrow
thisrow=cells(n,1)
nextrow=cells(n+1,1)
if thisrow=nextrow then
nextrow=cells(n+1,1).interior.color=cells(n+1,1).font.color
end if
End Sub

非常感谢，我真的很感谢你的努力。非常感谢，我真的很感谢你的努力。关于你的代码和我的代码完全一样，但是有两个问题。首先，项目名称重复很多，而且没有组织。例如（单元格A1显示项目1“标题”，A2显示项目1更新A3显示项目5“标题”，A4显示项目5更新，A5再次显示项目1“标题”（A1是project1标题，下面所有project1都会更新并重复标题。非常感谢您应该共享数据结构的快照，以及期望的结果-这将有助于了解您试图实现的目标这是数据库：（），这是我想要的]（）如你们所见，我想要的是将每个项目分组到单独的表中，或者至少用标题将它们分开。
Sub HideRepeatedNames()
'presuming project names are in column1
for n=1 to lastrow
thisrow=cells(n,1)
nextrow=cells(n+1,1)
if thisrow=nextrow then
nextrow=cells(n+1,1).interior.color=cells(n+1,1).font.color
end if
End Sub