過濾數據庫並將數據拆分爲表

Question

我有一個數據庫，它具有15個項目的狀態更新。數據庫每天更新，但並非所有項目每天都有更新。

我打算編寫一個代碼，以項目爲基礎過濾該數據庫，並將每個項目的所有更新合併到一張單獨的表上。

下面的代碼成功地組合了所選項目的更新並將其粘貼到另一個工作表上，但問題在於，因爲它是一個循環，每次if政治家都是真實的，它不止一次拷貝項目名稱。我想要的是幫助您如何只複製項目名稱1次並將其粘貼爲表格的標題，然後粘貼該項目的所有相關更新。

請注意，代碼將重複15次，因爲我有15個項目，但我下面只有project1所以請如果你也知道如何循環這種方式，而不是代碼15次重複，對於例如:(PROJECT1，項目2等）

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

「爲了避免項目名稱的重複，你運行另一個宏。下面的僞碼給出：

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