Need some help in making the code run faster.

[ittan]

Hi,
sorry it is a long code.
it is taking approximately 10sec. to execute.
I Want To :
1) shorten the its run time.
2) delete unnecessary lines code

Sub sortNpasteNreset()
' sortNpasteNreset Macro
    Dim i As Integer
    Dim su As Boolean, cm As XlCalculation
   
    su = Application.ScreenUpdating
    Application.ScreenUpdating = False 'Disable screen updating
    cm = Application.Calculation
    Application.Calculation = xlCalculationManual 'Disable automatic calculation

    i = 1
     Do
        'To sort the data
        Range("B17:D162").Delete shift:=xlToLeft
        Range("B164:D302").Delete shift:=xlToLeft
        
        'To Transpose everything before customer
        Range("B1:B17").Copy
        Cells(i + 1, 8).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        
        'To transpose the customers
        avlu = 7
        For rowx = 17 To 162 Step 1
            Cells(i + 1, rowx + avlu) = Cells(rowx, 2)
            Cells(i + 1, rowx + avlu + 1) = Cells(rowx, 3)
            avlu = avlu + 1
            Next
        
        'To transpose the PPID
        Range("B163:B302").Copy
        Cells(i + 1, 316).PasteSpecial Paste:=xlPasteAll, Transpose:=True
            
        'To Reset the WorkArea for new set of Data
        Range("A3:F302").Delete shift:=xlUp
        i = i + 1
        
     Loop While Cells(5, 1) <> 0
     
   'Tabulation
    Range("A1:G20").Delete shift:=xlToLeft
 
   'Double Quotes replace
    Cells.Replace What:="""", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Range("A1").Select
    
    'Better_cleanup keeps all the column with the word target
    Call better_cleanup
    
    'Assign value to customer target based on the Apply value
    Call CnP
    
    'Append the Apply value to the end and delete the apply value adjecent to the customer
    Call aPval_copy
   
   'AutoFit column
    Columns("A:XX").AutoFit
    
    Application.ScreenUpdating = su 'Restore screen updating
    Application.Calculation = cm 'Restore calculation mode
End Sub

Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
Set folder = fso.GetFolder("C:\Users\e1006133\Desktop\Project Excel\Test Files\Text file\")
'set the starting point to write the data to
Set cl = ActiveSheet.Cells(1, 1)
' Loop thru all files in the folder
For Each file In folder.Files
    ' Open the file
    Set FileText = file.OpenAsTextStream(ForReading)
    ' Read the file one line at a time
    Do While Not FileText.AtEndOfStream
        TextLine = FileText.ReadLine
        ' Parse the line into | delimited pieces
        Items = Split(TextLine, ",")
        ' Put data on one row in active sheet
        cl.Resize(1, UBound(Items) - LBound(Items) + 1).Value = Items
        ' Move to next row
        Set cl = cl.Offset(1, 0)
    Loop
    ' Clean up
    FileText.Close
Next file
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
Call sortNpasteNreset
End Sub
 
Sub better_cleanup()
Dim j As Long
For j = 451 To 19 Step -1
    If Not LCase(Cells(1, j).Value) Like "*target*" Then Columns(j).Delete
Next j
End Sub
 
Sub CnP()
    For i = 17 To 288
        For j = 300 To 385
            a = InStr(1, Cells(1, i), " ")
            txt1 = Mid(Cells(1, i), a + 1, Len(Cells(1, i)) - a)
            b = InStr(1, Cells(1, j), " ")
            txt2 = Mid(Cells(1, j), a + 1, Len(Cells(1, j)) - a)
            
                If txt1 = txt2 Then
                    
                    For k = 2 To Cells(Rows.Count, j).End(xlUp).Row
                        If Cells(k, i + 1) = 0 Then
                         Cells(k, i) = Cells(k, j)
                        End If
                    Next k
                    
                End If
            
        Next j
    Next i
            
End Sub
Sub aPval_copy()
j = 0
'add the ApplyValue columns to the end
For i = 18 To 298 Step 2
    ActiveSheet.Columns(i).Copy ActiveSheet.Columns(386 + j)
    j = j + 1
Next i
'delete the ApplyValue columns
For i = 298 To 18 Step -2
    Cells(1, i).EntireColumn.Delete
Next i
End Sub

 

[AlphaFrog]

This procedure should be a bit faster.

[COLOR=darkblue]Sub[/COLOR] CnP()
    
    [COLOR=darkblue]Dim[/COLOR] i [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR], txt1 [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR], Found [COLOR=darkblue]As[/COLOR] Range
    
    [COLOR=darkblue]For[/COLOR] i = 17 [COLOR=darkblue]To[/COLOR] 288
    
        txt1 = Mid(Cells(1, i), InStr(1, Cells(1, i), " ") + 1)
        
        [COLOR=darkblue]Set[/COLOR] Found = Cells(1, 300).Resize(, 86).Find(What:="*" & txt1, _
                                                    LookAt:=xlWhole, _
                                                    SearchOrder:=xlByColumns, _
                                                    SearchDirection:=xlNext, _
                                                    MatchCase:=False)
        
        [COLOR=darkblue]If[/COLOR] [COLOR=darkblue]Not[/COLOR] Found [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
            txt1 = Cells(1, i)
            Columns(i).Value = Found.EntireColumn.Value
            Cells(1, i).Value = txt1
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
        
    [COLOR=darkblue]Next[/COLOR] i
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]