Optimize Calculation

M

MrThor

New Member
Joined
Aug 13, 2018
Messages
36
Hi I have the following code getting data from text files and then performs calculations in my workbook. However, this code takes like 35 minutes to run. Is there any way to decrease the time? As you can see, I have the same dropbox directory but with different users, is this something that can be simplified? the first code for Private Sub 0() looks equal as the rest of them but with different textfiles. The code works but is really long...



Code: 
Private Sub noll()


Dim Resultat As Worksheet
Dim Indata As Worksheet
Dim noder As Worksheet


Set Resultat = Sheets("Resultat")
Set Indata = Sheets("Indata")
Set noder = Sheets("Alla noder")


Range("A:I").Delete


If ComboBox2.Value = "Wal" Then


    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\andre111\Dropbox\" a lot of text...."\noder 0.txt" _
        , Destination:=Range("$A$1"))
        .Name = "noder"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = True
        .TextFileOtherDelimiter = ""
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With


ElseIf ComboBox2.Value = "Bar" Then


    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\andre222\Dropbox\" a lot of text...."\noder 0.txt" _
        , Destination:=Range("$A$1"))
        .Name = "noder"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = True
        .TextFileOtherDelimiter = ""
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    
    ElseIf ComboBox2.Value = "Wal Hemma" Then


    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\andre333\Dropbox\" a lot of text...."\noder 0.txt" _
        , Destination:=Range("$A$1"))
        .Name = "noder"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = True
        .TextFileOtherDelimiter = ""
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With


ElseIf ComboBox2.Value = "Bar Hemma" Then


    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\andre444\Dropbox\" a lot of text...."\noder 0.txt" _
        , Destination:=Range("$A$1"))
        .Name = "noder"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = True
        .TextFileOtherDelimiter = ""
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    
    End If
    
    Range("A:A").Delete
    Range("B:I").Delete
    
    Range("A1").EntireRow.Insert
    
    Columns("A:A").Select
    ActiveWorkbook.Worksheets("Indata").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Indata").Sort.SortFields.Add Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Indata").Sort
        .SetRange Range("A:A")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    With Application.WorksheetFunction


For i = 2 To Range("A" & Rows.Count).End(xlUp).Row Step 1




    Indata.Cells(i, 2).Value = .Index(noder.Range("B1:B300000"), .Match(Indata.Cells(i, 1), noder.Range("A1:A300000"), 0))
    Indata.Cells(i, 3).Value = .Index(noder.Range("C1:C300000"), .Match(Indata.Cells(i, 1), noder.Range("A1:A300000"), 0))
    Indata.Cells(i, 4).Value = .Index(noder.Range("D1:D300000"), .Match(Indata.Cells(i, 1), noder.Range("A1:A300000"), 0))
    Indata.Cells(i, 5).Value = .Index(noder.Range("E1:E300000"), .Match(Indata.Cells(i, 1), noder.Range("A1:A300000"), 0))


Next i


End With
With Application.WorksheetFunction
Resultat.Cells(4, 7).Value = .Max(Range("E:E"))
Resultat.Cells(4, 6).Value = .Index(Indata.Range("D:D"), .Match(Resultat.Range("G4"), Indata.Range("E:E"), 0))
Resultat.Cells(4, 5).Value = .Index(Indata.Range("C:C"), .Match(Resultat.Range("G4"), Indata.Range("E:E"), 0))
Resultat.Cells(4, 4).Value = .Index(Indata.Range("B:B"), .Match(Resultat.Range("G4"), Indata.Range("E:E"), 0))
Resultat.Cells(4, 3).Value = .Index(Indata.Range("A:A"), .Match(Resultat.Range("G4"), Indata.Range("E:E"), 0))
End With


End Sub

Private Sub CommandButton2_Click()


Dim Resultat As Worksheet


Set Resultat = Sheets("Resultat")


Sheets("Indata").Select
Call noll
Call ett
Call två
Call tre
Call fyra
Call fem
Call sex
Call sju
Call åtta
Call nio
Call tio
Call elva
Call tolv
Call tretton
Call fjorton
Call femton
Call sexton
Call sjutton
Call arton
Call nitton
Call tjugo
Call tjugoett
Call tjugotvå
Call tjugotre
Call tjugofyra
Call tjugofem
Call tjugosex
Call tjugosju
Call tjugoåtta
Call tjugonio
Call trettio
Call trettioett
Call trettiotvå
Call trettiotre
Call trettiofyra
Call trettiofem
Call trettiosex
Call Roof
Call TopLevel
Call CraneLevel


Resultat.Select


Unload Me






End Sub
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
you are using for example

Code: 
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row Step 1




    Indata.Cells(i, 2).Value = .Index(noder.Range("B1:B300000"), .Match(Indata.Cells(i, 1), noder.Range("A1:A300000"), 0))
    Indata.Cells(i, 3).Value = .Index(noder.Range("C1:C300000"), .Match(Indata.Cells(i, 1), noder.Range("A1:A300000"), 0))
    Indata.Cells(i, 4).Value = .Index(noder.Range("D1:D300000"), .Match(Indata.Cells(i, 1), noder.Range("A1:A300000"), 0))
    Indata.Cells(i, 5).Value = .Index(noder.Range("E1:E300000"), .Match(Indata.Cells(i, 1), noder.Range("A1:A300000"), 0))


Next i

If you used "last row" then your ranges would adjust from 300000 to just that required

also in places you use E:E etc (over 1 million rows for comparison, when that could probably be reduced down)
 
Upvote 0
I will try that, do you know a way to save the different directorys in order to load the text files in a easier way?
 
Upvote 0
was thinking that a global declration of a variable for
"TEXT;C:\Users\andre111\Dropbox" a lot of text...."\noder 0.txt" _ andre111 could be made then you call each in a step and reuse, but I haven't looked at your individual options
 
Upvote 0
Like this
Code: 
Sub demo()

Dim LR
LR = Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LR Step 1

    Indata.Cells(i, 2).Value = .Index(noder.Range("B1:B" & LR), .Match(Indata.Cells(i, 1), noder.Range("A1:A" & LR), 0))
    Indata.Cells(i, 3).Value = .Index(noder.Range("C1:C" & LR), .Match(Indata.Cells(i, 1), noder.Range("A1:A" & LR), 0))
    Indata.Cells(i, 4).Value = .Index(noder.Range("D1:D" & LR), .Match(Indata.Cells(i, 1), noder.Range("A1:A" & LR), 0))
    Indata.Cells(i, 5).Value = .Index(noder.Range("E1:E" & LR), .Match(Indata.Cells(i, 1), noder.Range("A1:A" & LR), 0))


Next i

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Macro for CSV Import
Replies
9
Views
841
Legacy 143009
L
A
  • Solved
copy paste from one worksheet to other but in different columns
2
Replies
18
Views
840
Joe4
Joe4
C
  • Solved
Macros generates a named range every time it runs??
Replies
2
Views
314
chuggins143
C
S
  • Question
VBA query pasting data in with new columns rather than just pasting values into existing columns?
Replies
0
Views
441
SendHalp3
S
G
  • Solved
VBA - Text File Importer Always Brings Through the First File in the Directory
Replies
2
Views
411
ghost5
G

Forum statistics

Threads
1,216,360
Messages
6,130,175
Members
449,562
Latest member
mthrasher16

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