Sub FOLSPrePaidRatesListdeleteIrrelevantColumns()
'Call Rename 'rename sheet 1
Call Removebadlines 'remove all the lines that are blank and corrupted
Call AskIfRemoveFlexRates 'this calls importfile and delete not needed rows
Call FOLSPrePaidRates 'remove all the redundent columns that is not needed
Call DynamicRange 'this is what puts everything inside a table
Call Sortrange2 'this sorts certain columns as default, mainly the arrivals list
End Sub
Sub Rename()
Sheets(1).Name = "Sheet1"
End Sub
Sub Removebadlines()
LR3 = Range("A" & Rows.Count).End(xlUp).Row
For i3 = LR3 To 2 Step -1
If IsNumeric(Range("A" & i3).Value) And _
Len(Range("A" & i3).Value) > 0 Then
Else
Rows(i3).Delete
End If
Next i3
End Sub
Sub DeleteBlankRows()
Dim SourceRange As Range
Dim EntireRow As Range
Set SourceRange = Application.Selection
If Not (SourceRange Is Nothing) Then
Application.ScreenUpdating = False
For i = SourceRange.Rows.Count To 1 Step -1
Set EntireRow = SourceRange.Cells(i, 1).EntireRow
If Application.WorksheetFunction.CountA(EntireRow) = 0 Then
EntireRow.Delete
End If
Next
Application.ScreenUpdating = True
End If
End Sub
Sub FOLSPrePaidRates()
Dim keepColumn As Boolean
Dim currentColumn As Integer
Dim columnHeading As String
currentColumn = 1
While currentColumn <= ActiveSheet.UsedRange.Columns.Count
columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value
'CHECK WHETHER TO KEEP THE COLUMN
keepColumn = False
If columnHeading = "Guest_Name" Then keepColumn = True
If columnHeading = "BOOK_NUM" Then keepColumn = True
If columnHeading = "arrival_Date" Then keepColumn = True
If columnHeading = "Total_Amount" Then keepColumn = True
If columnHeading = "Deposit_Paid" Then keepColumn = True
If columnHeading = "Guaranty" Then keepColumn = True
If columnHeading = "Rate" Then keepColumn = True
If columnHeading = "Nationality" Then keepColumn = True
If keepColumn Then
'IF YES THEN SKIP TO THE NEXT COLUMN,
currentColumn = currentColumn + 1
Else
'IF NO DELETE THE COLUMN
ActiveSheet.Columns(currentColumn).Delete
End If
'LASTLY AN ESCAPE IN CASE THE SHEET HAS NO COLUMNS LEFT
If (ActiveSheet.UsedRange.Address = "$A$1") And (ActiveSheet.Range("$A$1").Text = "") Then Exit Sub
Wend
End Sub
Sub Sortrange2()
With ActiveSheet.Sort
With .SortFields
.Clear
.Add Key:=Range("C1"), SortOn:=xlSortOnValues, Order:=xlAscending
End With
.SetRange Range("A1").CurrentRegion
.Header = xlYes
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With ActiveSheet.Cells.EntireColumn.AutoFit
End With
End Sub
Sub FOLSReservationsResawebListdeleteIrrelevantColumns()
Call Removebadlines
Call FOLSResaweb
End Sub
Sub DynamicRange()
Dim tbl As ListObject
Dim Rng As Range
Set Rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Rng, , xlYes)
End Sub
Sub AskIfRemoveFlexRates()
Dim answer As Integer
answer = MsgBox("Do you wish to Remove Flexible Rates from this list?", vbQuestion + vbYesNo)
If answer = vbYes Then
Call RatesFileLoaded
Call delrows
'Call Macro2
'Call delrows2
Else
End If
End Sub
Sub RatesFileLoaded()
Dim answer As Integer
answer = MsgBox("Do you need to import the rates file?", vbQuestion + vbYesNo)
If answer = vbYes Then
Call ImportRates
Else: Sheets(1).Name = "Sheet1"
End If
End Sub
Sub ImportRates()
Sheets(1).Name = "Sheet1"
Sheets.Add(after:=Sheets("Sheet1")).Name = "Sheet2"
Dim wkbCrntWorkBook As Workbook
Dim wkbSourceBook As Workbook
Dim rngSourceRange As Range
Dim rngDestination As Range
Set wkbCrntWorkBook = ActiveWorkbook
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
Workbooks.Open .SelectedItems(1)
Set wkbSourceBook = ActiveWorkbook
Set rngSourceRange = Application.InputBox(prompt:="Select source range", Title:="Source Range", Default:="A1", Type:=8)
wkbCrntWorkBook.Activate
Set rngDestination = Application.InputBox(prompt:="Select destination cell", Title:="Select Destination", Default:="A1", Type:=8)
rngSourceRange.Copy rngDestination
rngDestination.CurrentRegion.EntireColumn.AutoFit
wkbSourceBook.Close False
End If
End With
End Sub
Sub delrows()
Worksheets("Sheet1").Activate
Dim d As Object
Dim a As Variant, b As Variant, itm As Variant
Dim nc As Long, i As Long, k As Long
Set d = CreateObject("Scripting.Dictionary")
a = Sheets("Sheet2").Range("A2", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Value
For Each itm In a
d(itm) = 1
Next itm
With Sheets("Sheet1")
a = .Range("X2", .Range("X" & Rows.Count).End(xlUp)).Value 'X is the rates column
ReDim b(1 To UBound(a), 1 To 1)
For i = 1 To UBound(a)
If Not d.exists(a(i, 1)) Then
k = k + 1
b(i, 1) = 1
End If
Next i
If k > 0 Then
Application.ScreenUpdating = False
nc = .Cells.Find(What:="*", LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column + 1
With .Range("A2").Resize(UBound(a), nc)
.Columns(nc).Value = b
.Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
.Resize(k).EntireRow.Delete
End With
Application.ScreenUpdating = True
End If
End With
End Sub
Sub Macro2()
Const lngStartRow As Long = 2 'Starting (static) row number for the row deletion. Change to suit if necessary.
Dim lngMyCol As Long, _
lngMyRow As Long
Dim xlnCalcMethod As XlCalculation
With Application
xlnCalcMethod = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Sheets("Sheet1").Select
lngMyCol = Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column + 1
lngMyRow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
With Columns(lngMyCol)
With Range(Cells(lngStartRow, lngMyCol), Cells(lngMyRow, lngMyCol))
.Formula = "=IF(ISERROR(VLOOKUP(X" & lngStartRow & ",Sheet2!A:A,1,FALSE)),"""",NA())"
ActiveSheet.Calculate
.Value = .Value
End With
On Error Resume Next 'Turn error reporting off - OK to ignore 'No cells found' message
.SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
On Error GoTo 0 'Turn error reporting back on
.Delete
End With
With Application
.Calculation = xlnCalcMethod
.ScreenUpdating = True
End With
MsgBox "All rows from Col. E where the number is Col. A of Sheet2 have now been deleted.", vbInformation
End Sub
Sub delrows2()
Dim d As Object, e, rws&, cls&, i&, j&
Set d = CreateObject("scripting.dictionary")
For Each e In Sheets("sheet2").Range("A1").CurrentRegion
d(e.Value) = 1
Next e
Sheets("sheet1").Activate
rws = Cells.Find("*", after:=[a1], searchorder:=xlByRows, _
searchdirection:=xlPrevious).Row
cls = Cells.Find("*", after:=[a1], searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
For i = rws To 1 Step -1
For j = 1 To cls
If d(Range("A1").Resize(rws, cls)(i, j).Value) = 1 Then _
Cells.Rows(i).Delete: Exit For
Next j, i
End Sub
Sub FOLSResaweb()
Dim keepColumn As Boolean
Dim currentColumn As Integer
Dim columnHeading As String
currentColumn = 1
While currentColumn <= ActiveSheet.UsedRange.Columns.Count
columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value
'CHECK WHETHER TO KEEP THE COLUMN
keepColumn = False
If columnHeading = "Guest_Name" Then keepColumn = True
If columnHeading = "Guest_FirstName" Then keepColumn = True
If columnHeading = "BOOK_NUM" Then keepColumn = True
If columnHeading = "Dep_Date" Then keepColumn = True
If columnHeading = "Total_Amount" Then keepColumn = True
If columnHeading = "Room_Type" Then keepColumn = True
If keepColumn Then
'IF YES THEN SKIP TO THE NEXT COLUMN,
currentColumn = currentColumn + 1
Else
'IF NO DELETE THE COLUMN
ActiveSheet.Columns(currentColumn).Delete
End If
'LASTLY AN ESCAPE IN CASE THE SHEET HAS NO COLUMNS LEFT
If (ActiveSheet.UsedRange.Address = "$A$1") And (ActiveSheet.Range("$A$1").Text = "") Then Exit Sub
Wend
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Range("C1"), xlSortOnValues, xlAscending
With ActiveSheet.Sort
.SetRange Range("A1").CurrentRegion
.Header = xlYes
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With ActiveSheet.Cells.EntireColumn.AutoFit
End With
End Sub
