Question

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

我计划编写的代码是基于项目编写过滤该数据库的代码，并将每个项目的所有更新组合在一个单独的表中。

下面的代码成功地组合了所选项目的更新并将其粘贴到另一个工作表上，但问题在于，因为它是一个循环，每次如果if statesmen为true，则复制项目名称不止一次。我想要的是如何只复制项目名称一次并将其粘贴为表格的标题，然后粘贴该项目的所有相关更新。

请注意，由于我有15个项目，代码将重复15次，但我在下面的内容仅适用于project1，所以如果您也知道如何循环此代码而不是重复代码15次，例如:( project1，project2等）

Sub report()

Sheet4.Activate

Dim project1 As String
Dim project2 As String
Dim project3 As String
Dim project4 As String
Dim project5 As String
Dim project6 As String
Dim project7 As String
Dim project8 As String
Dim project9 As String
Dim project10 As String
Dim project11 As String
Dim project12 As String
Dim project13 As String
Dim project14 As String
Dim project15 As String

Dim finalrow As Integer    
Dim i As Integer

project1 = Sheet4.Range("U1").Value
project2 = Sheet4.Range("U2").Value
project3 = Sheet4.Range("U3").Value
project4 = Sheet4.Range("U4").Value
project5 = Sheet4.Range("U5").Value
project6 = Sheet4.Range("U6").Value
project7 = Sheet4.Range("U7").Value
project8 = Sheet4.Range("U8").Value
project9 = Sheet4.Range("U9").Value
project10 = Sheet4.Range("U10").Value
project11 = Sheet4.Range("U11").Value
project12 = Sheet4.Range("U12").Value
project13 = Sheet4.Range("U13").Value
project14 = Sheet4.Range("U14").Value
project15 = Sheet4.Range("U15").Value

finalrow = Sheet4.Range("A2000").End(xlUp).Row    
i = 0

For i = 1 To finalrow
    If Cells(i, 1) = project1 Then
        Sheet7.Range("A100").End(xlUp).Offset(1, 0) = project1        

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

Sheet7.Activate                

End Sub

Answer 1

您可以使用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

Answer 2

＆＃39;为了避免重复项目名称，您运行另一个宏。伪代码如下：

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

过滤数据库并将数据拆分为表

2 个答案: