Speed Code & amend to shorten/neaten code

[mahmed1]

Hi All

This code works fine - i think

how can i amend this code to make it shorter/neater and speed it up

All im doing with the code is seperating each line by a question (currently all questions are across)

Hoping someone can help me

Many thanks

Sub transposeme()


Dim RawDatash As Worksheet
Dim Outputsh As Worksheet
Dim RefSh As Worksheet
Dim QuestionSh As Worksheet
Dim ws As Worksheet
Dim QuestionRange As Range


Dim i As Long
Dim Startrow As Long
Dim Lrow As Long
Dim Lcol As Long
Dim RawDataCol As Long
Dim OutputLR As Long
Dim MatchHeaders As Variant


Dim myType As String
Dim BaseSite As String
Set Outputsh = Worksheets("Output")
Set RefSh = Worksheets("Ref")
Set QuestionSh = Worksheets("Q Sheet")


'start row of data output from raw data
Startrow = 3


OutputLR = Outputsh.Range("A" & Rows.Count).End(xlUp).Row
        
        
    For Each ws In ThisWorkbook.Worksheets
    Debug.Print ws.Name
            'skip these sheets
        If ws.Name <> "Ref" And ws.Name <> "Output" And ws.Name <> "Q Sheet" Then
        
        Lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        Lcol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
            
        If Lrow = 3 Then
            'NO DATA
        Else
                   'Loop through each agent
               For i = Startrow To Lrow
                   myType = ws.Name
                    
                   
                   'Get Question Named Range
                   QuestionNamedRange = Application.WorksheetFunction.VLookup(myType, QuestionSh.Range("QuestionLookup"), 2, False)
                   Set QuestionRange = QuestionSh.Range(QuestionNamedRange)
           
                   For rr = 1 To QuestionRange.Rows.Count
                       
                       For cc = 3 To QuestionRange.Cells(rr, 1).Offset(, -1) + 2
                       
                           'Section Name
                            Outputsh.Cells(OutputLR, 5).Value = QuestionRange.Cells(rr, 1).Offset(, 1).Value
                            
                           'Loop through questions
                           'Question Name
        
                           Outputsh.Cells(OutputLR, 11).Value = QuestionRange.Cells(rr, cc).Value
                           
                           'Rating
                           
                               MatchHeaders = Application.Match(QuestionRange.Cells(rr, cc).Value, ws.Range(ws.Cells(2, 1), ws.Cells(2, Lcol)), 0)
                               'Outputsh.Cells(OutputLR, 12).Value = ws.Cells(i, MatchHeaders)
                               
                               If IsError(MatchHeaders) Then
                                   Outputsh.Cells(OutputLR, 12).Value = "N/A"
                               ElseIf ws.Cells(i, MatchHeaders) = "" Then
                                  Outputsh.Cells(OutputLR, 12).Value = "N/A"
                               Else
                                  Outputsh.Cells(OutputLR, 12).Value = ws.Cells(i, MatchHeaders)
                               End If
                           
                           'Loop through headers
                   
                       'Respondant
                       MatchHeaders = Application.WorksheetFunction.Match(RefSh.ListObjects("HeaderTable").ListColumns("Appears in Survey Monkey").DataBodyRange(1), ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol)), 0)
                       Outputsh.Cells(OutputLR, 1).Value = ws.Cells(i, MatchHeaders)
                       
                       'Name
                       MatchHeaders = Application.WorksheetFunction.Match(RefSh.ListObjects("HeaderTable").ListColumns("Appears in Survey Monkey").DataBodyRange(2), ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol)), 0)
                       Outputsh.Cells(OutputLR, 2).Value = ws.Cells(i, MatchHeaders)
                       
                       
                       'Date
                       MatchHeaders = Application.WorksheetFunction.Match(RefSh.ListObjects("HeaderTable").ListColumns("Appears in Survey Monkey").DataBodyRange(3), ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol)), 0)
                       Outputsh.Cells(OutputLR, 3).Value = DateValue(ws.Cells(i, MatchHeaders))
                       
                       
                       'URN
                       MatchHeaders = Application.WorksheetFunction.Match(RefSh.ListObjects("HeaderTable").ListColumns("Appears in Survey Monkey").DataBodyRange(4), ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol)), 0)
                       Outputsh.Cells(OutputLR, 6).Value = ws.Cells(i, MatchHeaders)
                       
                       'Lead Trainer
                       MatchHeaders = Application.WorksheetFunction.Match(RefSh.ListObjects("HeaderTable").ListColumns("Appears in Survey Monkey").DataBodyRange(6), ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol)), 0)
                       Outputsh.Cells(OutputLR, 9).Value = ws.Cells(i, MatchHeaders)
                         
                       'Base Site
                       MatchHeaders = Application.WorksheetFunction.Match(RefSh.ListObjects("HeaderTable").ListColumns("Appears in Survey Monkey").DataBodyRange(8), ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol)), 0)
          
                           Select Case ws.Cells(i, MatchHeaders)
                               Case Is = "Other (please specify)"
                                       BaseSite = "OTHER"
                               Case Is = "Lon"
                                       BaseSite = "London"
                               Case Is = "Der"
                                       BaseSite = "Derby"
                               Case Else
                                       BaseSite = "OTHER"
                           End Select
                           Outputsh.Cells(OutputLR, 10).Value = BaseSite
                       
                       'Type
                       Outputsh.Cells(OutputLR, 4).Value = myType
                  
                       OutputLR = OutputLR + 1
                       Next cc
                   Next rr
               Next i
          End If
       End If
    Next ws
End Sub

 

[iliace]

At first glance, it doesn't look like there are any optimizations you could introduce - the code looks pretty good to me. It is possible that you could get some efficiency by reading data into arrays instead of working with Lists or Ranges directly, but I cannot see immediately where you could do that.

What is the reason you are trying to optimize this code, and do you know what your bottlenecks might potentially be?

 

[mahmed1]

Hiya

ive added Optimisation code but is still taking 4-5 mins to update

i know that before it gets to the next row in my case variable i - once it macches the value and returns the value it will always be the same until it gets to next i

so the match doesn’t need to be performed each times irs going through the loop in rr to questionrange

the values that are stored for everything except question and rating is the same so all im doig there is really inputting the same value multiple times until it gets to next i - so the match doesn’t need to be performed each time in the loop