Posts by Simon Lloyd

Sub Macro2()
Dim T1
T1 = Sheets("Booking Page").Range("I3")
    Application.ReplaceFormat.Interior.ColorIndex = xlNone
    Cells.Replace What:=T1, Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
        
   Application.ReplaceFormat.Interior.ColorIndex = xlNone
    Cells.Replace What:=T1, Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End Sub

Sub RunCodeOnAllXLSFiles()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbMaster As Workbook


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False


On Error Resume Next


Set wbMaster = ThisWorkbook


With Application.FileSearch
.NewSearch
.LookIn = "C:\Documents and Settings\My Documents\Excel Test"
.FileType = msoFileTypeExcelWorkbooks
'.Filename = "Book*.xls"


If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all.
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)


Sheets("Sheet1").Select
Range("C4").Select
Selection.Copy
wbMaster.Activate
Workbooks("Wbworkbook").ActiveSheet.Range("B65536").End(xlUp)(2).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False


wbResults.Close SaveChanges:=True


Next lCount
End If
End With


On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

Dim rng As Range
Set rng = Range("A11")
If Not Intersect(Target, rng) Is Nothing Then 
With Sheet1
.AutoFilterMode = False
.Range("A14").AutoFilter
.Range("A14").AutoFilter Field:=1, Criteria1:="<={the number the user input}", _Operator:=xlAnd, Criteria2:="="
End With
Else:.AutoFilterMode = False
End If    
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rng As Range
    Dim MyCell
    Set rng = Range("A2:A100")
    If Not Intersect(Target, rng) Is Nothing Then
        With rng
            For Each MyCell In rng
                If MyCell = "" Then
                    MyCell.Select
                    MsgBox "Please use this next blank cell"
                    Exit Sub
                 
                End If
            Next
        End With
    End If
End Sub

Sub RunCodeOnAllXLSFiles()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbMaster As Workbook
Dim rng
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False


On Error Resume Next
Set rng = Sheets("Sheet1").Range("B65536").End(xlUp)(2) ''''assuming your pasting to sheet1
Set wbMaster = ThisWorkbook


With Application.FileSearch
.NewSearch
.LookIn = "S:\Common_Resources\PLs\2006\2006_06\Branch"
.FileType = msoFileTypeExcelWorkbooks
'.Filename = "Book*.xls"


If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all.
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)


Filename = ActiveCell.Value
sfilename = Filename
Workbooks.Open Filename:= _
(spath & sfilename)


Sheets("Sheet1").Select
Range("C4").Select
Selection.Copy
Windows("Branch Data.xls").Activate
rng.Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False


ActiveCell.Offset(0, -1).Range("A1").Select


Windows(sfilename).Activate


wbResults.Close SaveChanges:=True


Next lCount
End If
End With


On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rng As Range
Dim MyCell
Set rng = Range("A2:A100")
With rng
For Each MyCell In rng
If MyCell = "" Then
    MyCell.Select
    MsgBox "Please use this next blank cell"
Exit Sub
        
End If
Next
End With
End Sub

Sub FilterIt()
Dim T1, T2
Columns.AutoFilter  ''''''''This turns off any filters so if you run the code again you get to see everything first
T1 = InputBox("Enter Priority Number" & Chr(13) & "Either: 0, 1, 2 or 3", "Priority Finder")  '''''''''This is the method of allowing the user to enter which priority they would like to see
If T1 = "" Then ''''''these next 3 lines say if you dont select a number or press cancel then nothing happens
    Exit Sub
End If
    Range("A1").Select '''''selects where to start from
    Selection.AutoFilter   '''''turns filters on
    Selection.AutoFilter Field:=1, Criteria1:=T1   '''''''this tells it which feild to filter and by what
End Sub

Option Explicit 
 
Sub ReplaceThisWorkbookProcedures() 
     
    Dim N As Long 
    Dim NewCode As String 
     
     'ThisWorkbook is the file containing the new ThisWorkbook procedures
    With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule 
        NewCode = .Lines(1, .countoflines) 
    End With 
     
     'open all files you want the new procs in
    With Application 
        .ScreenUpdating = False 
        .DisplayAlerts = False 
        With .FileSearch 
            .LookIn = ThisWorkbook.Path 
            .Filename = "*.xls" 
            If .Execute > 0 Then 
                For N = 1 To .FoundFiles.Count 
                    If .FoundFiles(N) <> ThisWorkbook.FullName Then 
                        Workbooks.Open(.FoundFiles(N)).Activate 
                         
                         '--------Delete old procedures and replace with new--------
                        With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule 
                            .DeleteLines 1, .countoflines 
                            .InsertLines 1, NewCode 
                        End With 
                         '-----------------------------------------------------------------
                         
                        ActiveWorkbook.Close savechanges:=True 
                    End If 
                Next 
            End If 
        End With 
        .ScreenUpdating = True 
        .DisplayAlerts = True 
    End With 
     
End Sub