Solved: 5 small subs into 1 sub. HELP!

[kamuk000]

Hello

I need help to get 5 small subs into 1 sub. (run the whole program by pressing once.
Please see attached file with codes.

Ask if problems. Thank you. :)

[BigDawg15]

CROSS POST

http://www.excelforum.com/excel-programming-vba-macros/915096-5-small-subs-into-1-sub-help.html?p=3198407

BigDawg15

[SamT]

Not tested
Option Explicit

Sub GetAnsvarligProjekts()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error GoTo Exits

'Unmerges Cells
With Columns("A:W")
.UnMerge
.ColumnWidth = 10
End With

'Deletes first 17 rows
Rows("1:17").Delete Shift:=xlUp
Dim Rw As Long, Rng As Range, Col As Long

'Deletes empty rows
Set Rng = Range(Rows(1), Rows(Sheets("ServiceDriftMaaling").Cells.SpecialCells(xlCellTypeLastCell).Row()))
For Rw = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Rng.Rows(Rw).EntireRow) = 0 Then
Rng.Rows(Rw).EntireRow.Delete
End If
Next Rw

'Deletes empty colums
Set Rng = Range(Columns(1), Sheets("ServiceDriftMaaling").Cells.SpecialCells(xlCellTypeLastCell).Column())
For Col = Rng.Columns.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Rng.Columns(Col).EntireColumn) = 0 Then
Rng.Columns(Col).EntireColumn.Delete
End If
Next Col

'Deletes rows with various contents
For i = Cells(Rows.Count, "E").End(xlUp).Row To 1 Step -1
If (Cells(i, "E").Value) = "Tilbud" _
Or (Cells(i, "E").Value) = "Funktid" _
Or (Cells(i, "E").Value) = "Garanti" _
Or (Cells(i, "E").Value) = "Funktid" _
Or (Cells(i, "E").Value) = "Reklam." _
Or (Cells(i, "E").Value) = "Tløntid" _
Or (Cells(i, "E").Value) = "Unknown" _
Or (Cells(i, "E").Value) = "Ej fremdr." _
Or (Cells(i, "E").Value) = "Abn ej fre" _
Or (Cells(i, "E").Value) = "Abonnement" _
Or (Cells(i, "E").Value) = "Intern" _
Or (Cells(i, "E").Value) = "Inv.proj" Then
Rows(i).EntireRow.Delete 'Deletes row
End If
Next i

'Deletes rows with two contents
For i = Cells(Rows.Count, "E").End(xlUp).Row To 1 Step -1
If Cells(i, "J").Value = "Igangværende" And ( _
Cells(i, "E").Value = "ServiceER" _
Or Cells(i, "E").Value = "AbonER" _
Or Cells(i, "E").Value = "ServiceER" _
Or Cells(i, "E").Value = "ServiceFP") Then
Rows(i).EntireRow.Delete
End If
Next i

'Makes new Sheet if needed
Dim theWord As String, mySheetNameTest As String

theWord = InputBox("Please enter the employee's initials, Søg efter") 'column Ansvarlig
If theWord = "" Then Exit Sub

On Error Resume Next
mySheetNameTest = Worksheets(theWord).Name
If Err.Number = 0 Then
GoTo SheetExists
Else
Err.Clear
Worksheets.Add.Name = theWord
End If

SheetExists:

'CustomFind_CopyPaste()
Dim curRow
Sheets(theWord).Cells.ClearContents
Dim TheRange As Range
curRow = Sheets("ServiceDriftMaaling").Rows.Count.End(xlUp).Row
Set TheRange = Sheets("ServiceDriftMaaling").Range("E1:E" & CStr(curRow))

For Each cel In TheRange
If cel.Value = theWord Then
curRow = curRow + 1
cel.EntireRow.Copy Destination:=Sheets(theWord).Range("A" & curRow)
End If
Next cel

Exits:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

[kamuk000]

Thank you very much :)

Its solved.

[SamT]

You need to tell excelforum that it is solved

[kamuk000]

May I ask how?

[SamT]

CROSS POST

http://www.excelforum.com/excel-prog...html?p=3198407 (http://www.excelforum.com/excel-programming-vba-macros/915096-5-small-subs-into-1-sub-help.html?p=3198407)

BigDawg15
Go back there and post