何らかの理由で、このスクリプトが[PO Tracking]タブにエクスポートされると、最後の2行はフォーマットされないままになります...コードでそれを考慮に入れる必要があると私が知る限り、理由はわかりません。誰かが以下のコードを覗いて、どこで調整する必要があるかを教えてくれたら、とてもありがたいです。
Option Explicit
Sub PO_Tracking()
Dim wsPOD As Worksheet
Dim wsPOT As Worksheet
Dim wsPOA As Worksheet
Dim cel As Range
Dim lastrow As Long, i As Long, Er As Long
Set wsPOD = Sheets("PO Data")
Set wsPOT = Sheets("PO Tracking")
Set wsPOA = Sheets("PO Archive")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
With wsPOD
'first bring columns F:G up to match their line
For Each cel In Intersect(.UsedRange, .UsedRange.Offset(5), .Columns(6))
If cel = vbNullString And cel.Offset(, -2) <> vbNullString Then
.Range(cel.Offset(1), cel.Offset(1, 1)).Copy cel
cel.Offset(1).EntireRow.Delete
End If
Next
'now fil columns A:D to match PO Date and PO#
For Each cel In Intersect(.UsedRange, .UsedRange.Offset(5), .Columns(1))
If cel = vbNullString And cel.Offset(, 5) <> vbNullString Then
.Range(cel.Offset(-1), cel.Offset(-1, 3)).Copy cel
End If
Next
'Blow away rows that are useless
lastrow = wsPOD.Range("A6").End(xlDown).Row
wsPOD.Range("M5:P5").Copy wsPOD.Range("M6:P" & lastrow)
Calculate
With Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("N"))
.AutoFilter 1, "<>Different"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
With Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("P"))
.AutoFilter 1, "<>"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
lastrow = wsPOD.Range("A6").End(xlDown).Row
wsPOD.UsedRange.Copy Sheets.Add.Range("A1")
'Final Adjustments before transfering over to new sheet.
With ActiveSheet
.AutoFilterMode = False
Intersect(.UsedRange, .Columns("A")).Cut .Range("Q1")
Intersect(.UsedRange, .Columns("D")).Cut .Range("R1")
Intersect(.UsedRange, .Columns("C")).Cut .Range("S1")
Intersect(.UsedRange, .Columns("B")).Cut .Range("T1")
Intersect(.UsedRange, .Columns("G")).Cut .Range("U1")
Intersect(.UsedRange, .Columns("F")).Cut .Range("V1")
Intersect(.UsedRange, .Range("Q:V")).Copy wsPOT.Cells(Rows.Count, "B").End(xlUp).Offset(1)
.Delete
End With
lastrow = wsPOD.Cells(Rows.Count, "B").End(xlUp).Row
wsPOT.Range("R1:X1").Copy
wsPOT.Range("B3:H" & lastrow).PasteSpecial xlPasteFormats
wsPOT.Range("N2:O2").Copy wsPOT.Range("N3:O" & lastrow)
wsPOT.Range("P1:Q1").Copy wsPOT.Range("I3:J" & lastrow)
wsPOT.Range("K3:K" & lastrow).Borders.Weight = xlThin
End With
Application.CutCopyMode = False
End Sub
こちらがExcelシートです。
http://dl.dropbox.com/u/3327208/Excel/Last%20two%20rows.xlsm