У меня странная проблема при обновлении книг Excel для консультантов.Похоже, что фильтрация работает неправильно, поскольку она не всегда выбирает имя консультанта из wsTarget
для фильтрации wbSource
.
Я действительно ослеплен, потому что это работает для некоторых имен и не для других.Я дважды проверил, и имена совпадают в wsTarget
и wsSource
.
Есть предложения?
Sub CopyToWorkbooks()
Application.ScreenUpdating = False
Dim strPath As String
Dim strFile As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsConsultant As Worksheet
Dim wsTarget As Worksheet
Dim cons As Range
strPath = "xxx"
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Set wsSource = Workbooks("JobsOn.xlsm").Worksheets("TOCOPY")
strFile = Dir(strPath & "*.xlsx*")
Do Until strFile = ""
If strFile <> ThisWorkbook.Name Then
Set wbtarget = Workbooks.Open(strPath & strFile)
Set wsTarget = wbtarget.Worksheets("Revenue Tracker")
Set cons = wbtarget.Worksheets("Revenue Tracker").Range("C1")
wsSource.Range("$A$1:$F$10000").AutoFilter Field:=5, Criteria1:=cons
wsTarget.Unprotect Password:="xxx"
On Error Resume Next
wsSource.Range("B2:B37").SpecialCells(xlCellTypeVisible).Copy
wsTarget.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).PasteSpecial xlPasteValues
wsSource.Range("C2:C37").SpecialCells(xlCellTypeVisible).Copy
wsTarget.Cells(Rows.Count, 1).End(xlUp).Offset(1, 2).PasteSpecial xlPasteValues
wsSource.Range("D2:D37").SpecialCells(xlCellTypeVisible).Copy
wsTarget.Cells(Rows.Count, 1).End(xlUp).Offset(1, 4).PasteSpecial xlPasteValues
'wsSource.Range("F2:F37").SpecialCells(xlCellTypeVisible).Copy
'wsTarget.Cells(Rows.Count, 1).End(xlUp).Offset(1, 8).PasteSpecial xlPasteValues
wsSource.Range("A2:A37").SpecialCells(xlCellTypeVisible).Copy
wsTarget.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
wsTarget.Columns.AutoFit
wsTarget.Protect Password:="jayne", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.DisplayAlerts = False
wbtarget.Save
wbtarget.Close
Application.DisplayAlerts = True
wsSource.AutoFilter.ShowAllData
End If
strFile = Dir()
Loop
Worksheets("UNIQUE").Range("A2:F100000").FormatConditions.Delete
Worksheets("UNIQUE").Range("G2:G100000").Clear
wsSource.Range("A2:F10000").Clear
Application.ScreenUpdating = True
End Sub