With Sheets(Sheet1).Range("A1:i1")
.Interior.Color = RGB(190, 255, 188)
.Merge
.HorizontalAlignment = xlLeft
End With
Borders Cell
With Sheets(Sheet1).Range("A2:I2").Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
Find message and endtire row insert color row
Set findrow2 = Sheets("ALL").Cells.Find(Filename7, After:=Cells(1, 1), LookIn:=xlValues)
With Rows(findrow2.Row)
.EntireRow.Insert
.Interior.ColorIndex = xlNone
.EntireRow.Insert
.Offset(-1).Interior.ColorIndex = xlNone
.Offset(-2).Interior.ColorIndex = xlNone
End With
Sheets("ALL").Cells.Find(What:=Filename7, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
With Selection.Interior
.ColorIndex = 35
.Pattern = xlSolid
End With
Auto fit columns
Sheets("ALL").Columns("B:G").EntireColumn.AutoFit
Sub failedddd()
Find and add fil color
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
'What value do you want to find (must be in string form)?
fnd = "Failed"
Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(What:=fnd, After:=LastCell)
'Test to see if anything was found
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
End If
Set rng = FoundCell
'Loop until cycled through all unique finds
Do Until FoundCell Is Nothing
'Find next cell with fnd value
Set FoundCell = myRange.FindNext(After:=FoundCell)
'Add found cell to rng range variable
Set rng = Union(rng, FoundCell)
'Test to see if cycled through to first found cell
If FoundCell.Address = FirstFound Then Exit Do
Loop
'Highlight Found cells yellow
With rng
.Offset(0, 0).Interior.Color = RGB(255, 203, 203)
.Offset(0, 1).Interior.Color = RGB(255, 203, 203)
.Offset(0, 2).Interior.Color = RGB(255, 203, 203)
.Offset(0, 3).Interior.Color = RGB(255, 203, 203)
.Offset(0, 4).Interior.Color = RGB(255, 203, 203)
.Offset(0, 5).Interior.Color = RGB(255, 203, 203)
.Offset(0, 6).Interior.Color = RGB(255, 203, 203)
.Offset(0, 7).Interior.Color = RGB(255, 203, 203)
.Offset(0, 8).Interior.Color = RGB(255, 203, 203)
End With
With rng.Offset(0, 0).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
With rng.Offset(0, 1).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
With rng.Offset(0, 2).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
With rng.Offset(0, 3).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
With rng.Offset(0, 4).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
With rng.Offset(0, 5).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
With rng.Offset(0, 6).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
With rng.Offset(0, 7).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
With rng.Offset(0, 8).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
End Sub
'Check Folder and Create new Folder
If Dir(newfolder1 & newfolder6, vbDirectory) = "" Then
MkDir newfolder1 & newfolder6
End If
Copy file
FileCopy Folderfilesrc & Filename1, newfolder4 & newfolder9 & "/" & newfilename1
Copy sheets and Create new excel
Set NewBook = Workbooks.Add
ThisWorkbook.Sheets(Sheet1).Copy Before:=NewBook.Sheets(1)
ThisWorkbook.Sheets(Sheet2).Copy Before:=NewBook.Sheets(2)
ThisWorkbook.Sheets(Sheet3).Copy Before:=NewBook.Sheets(3)
ThisWorkbook.Sheets(Sheet4).Copy Before:=NewBook.Sheets(4)
ThisWorkbook.Sheets(Sheet5).Copy Before:=NewBook.Sheets(5)
ThisWorkbook.Sheets("ALL").Copy Before:=NewBook.Sheets(6)
If Dir(FPath & FPath1 & "\" & FName) <> "" Then
MsgBox "File " & FPath & FPath1 & FName & " already exists"
Else
NewBook.SaveAs Filename:=FPath & FPath1 & "\" & FName
End If
Windows(Filereport).Activate
Sheets(Array("" & Sheet1 & "", "" & Sheet2 & "", "" & Sheet3 & "", "" & Sheet4 & "", _
"" & Sheet5 & "", "ALL")).Select
ActiveWindow.SelectedSheets.Delete
'Selection.ClearFormats
ActiveWorkbook.Worksheets.Add
Sheets(Sheets(1).Name).Name = "ALL"
MsgBox "Complete."
Unload UserForm1
End Sub
0 ความคิดเห็น