我的目標是:我需要能夠從不同的工作簿中取出兩個不同的工作表,並將它們合併到一個工作表中幷包含兩個工作表(已完成)。其中一個工作表將來自舊數據並用作主清單,而另一個工作表將包含舊數據以及新數據(以及對舊數據的更改)。我需要能夠清除主列表中已有的舊數據,但仍要檢查舊數據是否有任何更改(信息將從新信息工作表中刪除)。最終目標是製作兩個工作表:1包含舊信息(已完成),1包含新信息和對新信息的任何更改(需要幫助)。Excel VBA - 創建僅包含新信息和變更的新電子表格
我有什麼現在:
子DocumentInspector()
Dim RowCount As Integer
Dim Row As Integer
Dim Column As Integer
Dim ColumnCount As Integer
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim i As Integer
Dim count As Integer
Dim count2 As Integer
count2 = 0
i = 0
count = 0
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "F:\ \Document Inspector" ' change to suit
Set wbDst = Workbooks("DocumentInspector.xlsm")
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.count)
strFilename = Dir()
Loop
wbDst.Worksheets(2).Name = "Old Information"
wbDst.Worksheets(3).Name = "New Information"
'MUST CHANGE RANGES
RowCount = Sheets("New Information").UsedRange.Rows.count
ColumnCount = Sheets("New Information").UsedRange.Columns.count
'MUST CHANGE RANGE
For Each x In Sheets("Old Information").Range("A1:E10")
For Row = 2 To RowCount
For Column = 1 To ColumnCount
If x.Value = Sheets("New Information").Cells(Row, Column).Value Then
Sheets("New Information").Cells(Row, Column).Interior.Color = RGB(255, 255, 0)
End If
Next Column
Next Row
Next
For Row = 2 To RowCount
For Column = 1 To ColumnCount
If Sheets("New Information").Cells(Row, Column).Interior.Color = RGB(255, 255, 0) Then
Sheets("New Information").Cells(Row, Column).Interior.Color = xlNone
count = count + 1
Else
Sheets("New Information").Cells(Row, Column).Interior.Color = RGB(255, 255, 0)
count2 = count2 + 1
End If
Next Column
If count = ColumnCount Then
Sheets("New Information").Rows(Row).EntireRow.Interior.Color = xlNone
Sheets("New Information").Rows(Row).EntireRow.Delete
Row = Row - 1
ElseIf count2 = ColumnCount Then
Sheets("New Information").Rows(Row).EntireRow.Interior.Color = xlNone
Sheets("New Information").Rows(Row).EntireRow.Delete
End If
count2 = 0
count = 0
Next Row
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
末次
這將工作如果兩個工作表上的行應該是相同的,那麼行數會有所不同。行可以在工作表上的任何位置,我需要能夠刪除它們,如果它們是舊的並突出顯示新信息。 – CennerB
如果數據位於工作表中的任何位置,並且需要過濾並保持需要,則可以執行此操作。 – Punith