Can this coding be optomized!?!

E

excel_2009

Active Member
Joined
Sep 14, 2009
Messages
318
Hi excel gurus,

I've created the following coding (thanks to alot of help from this site!!! :)) it works perfectly fine, however i was just wondering if it can be optomized/more efficient? :)


Code: 
Sub Execute()
Dim ws3 As Worksheet

Application.DisplayAlerts = False

Sheets("Home").Select
Cells(12, 8) = "Total Offers"
Cells(12, 10).ClearContents
Cells(13, 8) = "Total Matches"
Cells(13, 10).ClearContents
Cells(14, 8) = "Matches %"
Cells(14, 10).ClearContents
 
 
For Each ws3 In ActiveWorkbook.Worksheets
If ws3.Name = "Home" Or ws3.Name = "Cats" Then
Else
ws3.Visible = xlSheetVisible
ws3.Delete
End If
Next ws3

bStatusState = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "....Processing the work please wait"

Application.DisplayAlerts = True

Application.ScreenUpdating = False

Dim FilesToOpen
Dim x As Integer
Dim DestWB As Workbook
Dim wkbTemp As Workbook
Dim lRealLastRow As Long
Dim lRealLastColumn As Long
Dim lRealLastRow1 As Long
Dim lRealLastColumn1 As Long
Dim lRealLastRow2 As Long
Dim lRealLastColumn2 As Long
Dim lRealLastRow3 As Long
Dim lRealLastColumn3 As Long
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim j As Long



'Application.DisplayAlerts = False


'open both files
 
 Set DestWB = Workbooks("TestFile.xlsm")
On Error GoTo ErrHandler
 Updating = False
FilesToOpen = Application.GetOpenFilename _
    (FileFilter:="Text Files (*.txt), *.txt", _
    MultiSelect:=True, Title:="Text Files to Open")
If TypeName(FilesToOpen) = "Boolean" Then
    MsgBox "No Files were selected"
    GoTo ExitHandler
End If
For x = 1 To UBound(FilesToOpen)
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
wkbTemp.Sheets(1).Copy DestWB.Sheets(1)
wkbTemp.Close (True)
    With DestWB
        .Sheets(1).Move After:=.Sheets(Sheets.Count)
        .Worksheets(.Sheets.Count).Columns("A:A").TextToColumns _
            Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDelimited, _
            ConsecutiveDelimiter:=True, _
            Tab:=True, Semicolon:=True, _
            Comma:=True, SCOMIC1e:=True, _
            Other:=True, OtherChar:=","
    End With
Next


'rename the sheets to a specified name'

For Each ws In Worksheets

If ws.Name Like "*offers_to_classify*" Then ws.Name = "COMIC1"
Next ws

For Each ws1 In Worksheets

If ws1.Name Like "*clothing*" Or ws1.Name Like "*adult*" Or ws1.Name Like "*appliances*" Or ws1.Name Like "*automative*" Or ws1.Name Like "*kids*" Or ws1.Name Like "*computers*" Or ws1.Name Like "*electronics*" Or ws1.Name Like "*gifts*" Or ws1.Name Like "*gifts*" Or ws1.Name Like "*health*" Or ws1.Name Like "*home*" Or ws1.Name Like "*jewellery*" Or ws1.Name Like "*musical*" Or ws1.Name Like "*office*" Or ws1.Name Like "*pet*" Or ws1.Name Like "*sports*" Or ws1.Name Like "*toys*" Or ws1.Name Like "*consoles*" Then ws1.Name = "Output1"
Next ws1




'insert the formulas and new column headers

' Updating = False

Sheets("COMIC1").Select

lRealLastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
lRealLastRow = Cells(Rows.Count, lRealLastColumn).End(xlUp).Row
Range(Cells(2, lRealLastColumn), Cells(lRealLastRow, lRealLastColumn)) = _
Range(Cells(2, lRealLastColumn), Cells(lRealLastRow, lRealLastColumn)).Value
 
Range(Cells(2, lRealLastColumn + 1), Cells(lRealLastRow, lRealLastColumn + 1)).Formula = _
"=IF(ISNA(VLOOKUP(A2,Output1!C:H,6,0)),0,(VLOOKUP(A2,Output1!C:H,6,0)))"
lRealLastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
lRealLastRow = Cells(Rows.Count, lRealLastColumn).End(xlUp).Row
 
Range(Cells(2, lRealLastColumn - 1), Cells(lRealLastRow, lRealLastColumn - 1)) = _
Range(Cells(2, lRealLastColumn - 1), Cells(lRealLastRow, lRealLastColumn - 1)).Value

Range(Cells(2, lRealLastColumn), Cells(lRealLastRow, lRealLastColumn)) = _
Range(Cells(2, lRealLastColumn), Cells(lRealLastRow, lRealLastColumn)).Value
 
Cells(1, lRealLastColumn - 0) = "Output1"


lRealLastColumn1 = Cells(2, Columns.Count).End(xlToLeft).Column
lRealLastRow1 = Cells(Rows.Count, lRealLastColumn1).End(xlUp).Row
Range(Cells(2, lRealLastColumn1), Cells(lRealLastRow1, lRealLastColumn1)) = _
Range(Cells(2, lRealLastColumn1), Cells(lRealLastRow1, lRealLastColumn1)).Value
 
Range(Cells(2, lRealLastColumn1 + 1), Cells(lRealLastRow1, lRealLastColumn1 + 1)).Formula = _
"=IF(ISNA(VLOOKUP(A2,Output1!C:N,9,0)),0,(VLOOKUP(A2,Output1!C:N,9,0)))" '''''''''''
lRealLastColumn1 = Cells(2, Columns.Count).End(xlToLeft).Column
lRealLastRow1 = Cells(Rows.Count, lRealLastColumn1).End(xlUp).Row
 
Range(Cells(2, lRealLastColumn1 - 1), Cells(lRealLastRow1, lRealLastColumn1 - 1)) = _
Range(Cells(2, lRealLastColumn1 - 1), Cells(lRealLastRow1, lRealLastColumn1 - 1)).Value

Range(Cells(2, lRealLastColumn1), Cells(lRealLastRow1, lRealLastColumn1)) = _
Range(Cells(2, lRealLastColumn1), Cells(lRealLastRow1, lRealLastColumn1)).Value
 
Cells(1, lRealLastColumn1 - 0) = "Output2"


lRealLastColumn2 = Cells(2, Columns.Count).End(xlToLeft).Column
lRealLastRow2 = Cells(Rows.Count, lRealLastColumn2).End(xlUp).Row
Range(Cells(2, lRealLastColumn2), Cells(lRealLastRow2, lRealLastColumn2)) = _
Range(Cells(2, lRealLastColumn2), Cells(lRealLastRow2, lRealLastColumn2)).Value
 
Range(Cells(2, lRealLastColumn2 + 1), Cells(lRealLastRow2, lRealLastColumn2 + 1)).Formula = _
"=IF(ISNA(VLOOKUP(A2,Output1!C:N,9,0)),0,(VLOOKUP(A2,Output1!C:N,12,0)))" ''''''''''''''''''''''''''''
lRealLastColumn2 = Cells(2, Columns.Count).End(xlToLeft).Column
lRealLastRow2 = Cells(Rows.Count, lRealLastColumn2).End(xlUp).Row
 
Range(Cells(2, lRealLastColumn2 - 1), Cells(lRealLastRow2, lRealLastColumn2 - 1)) = _
Range(Cells(2, lRealLastColumn2 - 1), Cells(lRealLastRow2, lRealLastColumn2 - 1)).Value

Range(Cells(2, lRealLastColumn2), Cells(lRealLastRow2, lRealLastColumn2)) = _
Range(Cells(2, lRealLastColumn2), Cells(lRealLastRow2, lRealLastColumn2)).Value
 
Cells(1, lRealLastColumn2 - 0) = "Output3"

lRealLastColumn3 = Cells(2, Columns.Count).End(xlToLeft).Column
lRealLastRow3 = Cells(Rows.Count, lRealLastColumn3).End(xlUp).Row
Range(Cells(2, lRealLastColumn3), Cells(lRealLastRow3, lRealLastColumn3)) = _
Range(Cells(2, lRealLastColumn3), Cells(lRealLastRow3, lRealLastColumn3)).Value

Range(Cells(2, lRealLastColumn3 + 1), Cells(lRealLastRow3, lRealLastColumn3 + 1)).Formula = _
"=COUNTIF(I2:AH2, B2)"
lRealLastColumn3 = Cells(2, Columns.Count).End(xlToLeft).Column
lRealLastRow3 = Cells(Rows.Count, lRealLastColumn3).End(xlUp).Row

Range(Cells(2, lRealLastColumn3 - 1), Cells(lRealLastRow3, lRealLastColumn3 - 1)) = _
Range(Cells(2, lRealLastColumn3 - 1), Cells(lRealLastRow3, lRealLastColumn3 - 1)).Value

Range(Cells(2, lRealLastColumn3), Cells(lRealLastRow3, lRealLastColumn3)) = _
Range(Cells(2, lRealLastColumn3), Cells(lRealLastRow3, lRealLastColumn3)).Value
 
Cells(1, lRealLastColumn3 - 0) = "Matches"


'delete the COMIC1 probability columns to tidy up the results


With ActiveSheet
For i = .UsedRange.Columns.Count To 1 Step -1
If Application.WorksheetFunction.CountIf(.Columns(i), "*COMIC1 Probability") Then
.Columns(i).Delete


End If
Next
End With


'With Sheets("COMIC1")
'
'    .Columns("M").EntireColumn.Delete
'    .Columns("O").EntireColumn.Delete
'    .Columns("Q").EntireColumn.Delete
'    .Columns("S").EntireColumn.Delete
'    .Columns("U").EntireColumn.Delete
'    .Columns("W").EntireColumn.Delete
'    .Columns("Y").EntireColumn.Delete
'    .Columns("AA").EntireColumn.Delete
'    .Columns("AC").EntireColumn.Delete
'    .Columns("AE").EntireColumn.Delete
'
'
'End With
'






'formulas for the home sheet

Sheets("Home").Select

Cells(12, 8) = "Total Offers"
Cells(12, 10) = "=COUNT(COMIC1!A:A)"

Cells(13, 8) = "Total Matches"
Cells(13, 10) = "=COUNTIF(COMIC1!Y:Y,2)"

Cells(14, 8) = "Matches %"
Cells(14, 10) = "=J13/J12"

'add new sheet export for the creation of the file to be exported
Sheets.Add.Name = "Export"

'select COMIC1 sheet, all the contents on the sheet that have 2 mathces
Sheets("COMIC1").Select
    
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("A:Y").AutoFilter Field:=25, Criteria1:="2"
    Cells.Select
    Selection.Copy
    
'paste the results onto the Export sheet and delete the irelevant columns to prep the file for export
Application.ScreenUpdating = False

    Sheets("Export").Select
    Range("A1").Select
    ActiveSheet.Paste

With ActiveSheet
For j = .UsedRange.Columns.Count To 1 Step -1
If WorksheetFunction.CountIf(.Columns(j), "*Matches") Or WorksheetFunction.CountIf(.Columns(j), "*Noun Match*") Or WorksheetFunction.CountIf(.Columns(j), "*COMIC1*") Or WorksheetFunction.CountIf(.Columns(j), "*Parent*") Or WorksheetFunction.CountIf(.Columns(j), "*URL*") Or WorksheetFunction.CountIf(.Columns(j), "*Description*") Then
.Columns(j).Delete
End If
Next
End With


   Columns("C:C").Select
   Selection.Cut
   Columns("A:A").Select
   Selection.Insert Shift:=xlToRight
   Columns("D:D").Select
   Selection.Cut
   Columns("B:B").Select
   Selection.Insert Shift:=xlToRight
   Columns("A:A").Select
   Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   Range("A1").Select
   ActiveCell.FormulaR1C1 = "atomid"
   Selection.AutoFill Destination:=Range("A1:A" & Range("B" & Rows.Count).End(xlUp).Row)
   Rows("1:1").Select
   Selection.Delete Shift:=xlUp


Sheets("COMIC1").Select
ActiveSheet.ShowAllData
Selection.AutoFilter
Range("A1").Select

Sheets("Export").Select
Sheets("Export").Move After:=Sheets(4)
Range("A1").Select
Sheets("Home").Select

'change sheet colour

    Sheets("Home").Select
    With ActiveWorkbook.Sheets("Home").Tab
        .Color = 13395507
        .TintAndShade = 0
    End With
    Sheets("Output1").Select
    With ActiveWorkbook.Sheets("Output1").Tab
        .Color = 13395456
        .TintAndShade = 0
    End With
     Sheets("COMIC1").Select
    With ActiveWorkbook.Sheets("COMIC1").Tab
        .Color = 16750899
        .TintAndShade = 0
    End With
    Sheets("Export").Select
    With ActiveWorkbook.Sheets("Export").Tab
        .Color = 16750899
        .TintAndShade = 0
    End With


Sheets("Home").Select


Application.StatusBar = False
Application.DisplayStatusBar = bStatusState



'error handler for opening both text files, do not move
ExitHandler:
 Updating = True
Set wkbAll = Nothing
Set wkbTemp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler

Application.ScreenUpdating = True
     

End Sub
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
Sort by date Sort by votes
You must log in or register to reply here.

Similar threads

C
  • Solved
Copy data from multiple sheets into a master sheet - VBA button stuck
Replies
3
Views
338
NdNoviceHlp
NdNoviceHlp
K
  • Solved
Code to search job id from multiple sources and update main spreadsheet.
2
Replies
10
Views
677
mumps
mumps
Logit
  • Question Question
Search In Other Workbook - Copy/Paste Offset Data To First Workbook - Repeat Process
Replies
7
Views
354
Logit
Logit
M
  • Solved
VBA to Insert Mismatched Row in separate worksheet
2 3
Replies
21
Views
777
Peter_SSs
Peter_SSs
N
  • Question Question
Finding the differences then copy and paste code to a new sheet
Replies
1
Views
663
myall_blues
myall_blues

Forum statistics

Threads
1,224,594
Messages
6,179,795
Members
452,943
Latest member
Newbie4296

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top