title: Modify Excel VBA code to make it work faster
body: <p>I have a file with more then 100k rows, but the structure is simple:</p>
  
  <pre><code>Date       | Name-Position-Color | Summ
  17.11.2015 |"Name1               | 8813,52
             | Position1           |
            _|_Color1"            _|_
  19.08.2015 |"Name2               | 3587,86
             | Position3           |
            _|_Color5"            _|_
  12.01.2015 |"Name3               | 14,63
             | Position16          |
            _|_Color7"            _|_
  07.12.2015 |"Name4               | 7129,97
             | Position11          |
             | Color3"             |
  </code></pre>
  
  <p>Result should be twelve identically formed tables from "Jan" to "Dec" sliced from "Name-Position-Color" column sheet1 placed into sheet3 as "Name-slice" -column and "Position-slice" -head row. The "color" part is no longer needed. Tables should be filled with multiplied "Name-slice" by "Position-slice" including a period in which they're positioned in the first list. I hope this is informative enough to understand. So, I've managed to write a macro (it's located just a few lines below), but it works really slow even when I have only 228 rows in the list. It had worked fast just before I've added a calculation part. I think object programming could save some time, but I haven't learned it yet. I would really appreciate if someone could tell me the way to improve my code, so it'll work faster. Any advice would be really helpful too... Thanks. You can see the whole code below.</p>
  
  <pre><code>Sub tablesByMonths()
  
  'def column in sheet1
  colNum1 = 2
  'def column in sheet3
  colNum3 = 2 '2 is minimal for correct macro work
  'def last row in sheet1
  lastRow1 = Worksheets("Sheet1").Cells(Rows.Count, colNum1).End(xlUp).Row
  'def first row in sheet1
  firstRow1 = Worksheets("Sheet1").Cells(Rows.Count,     colNum1).End(xlUp).End(xlUp).Row + 1
  'def last row in sheet3
  step = 2
  
  Application.ScreenUpdating = False                  'turns off dynamic screen update
  Application.Calculation = xlCalculationManual       'turns off automatic formulas
  
  'clears all used range in a sheet3
  Worksheets("Sheet3").UsedRange.Clear
  
  'this counts months from Jan to Dec
  For per = 1 To 12
  
  'def last row in sheet3
  lastRow3_1 = Worksheets("Sheet3").Cells(Rows.Count, colNum3).End(xlUp).Row
  'puts current number from per loop and adds "/01/2015"
  Worksheets("Sheet3").Cells(lastRow3_1 + step, colNum3 - 1).Value = per &amp; "/01/2015"
  'converts date into month format
  Worksheets("Sheet3").Cells(lastRow3_1 + step, colNum3 - 1).NumberFormat = "mmmm"
  
  'loop through the entire list in a sheet1 column colNum1
  For x = firstRow1 To lastRow1
  
      'def current cell value
      curVal1 = Worksheets("Sheet1").Cells(x, colNum1)
      'def first space position in curVal1
      spacePos1 = InStr(1, curVal1, Chr(10), vbBinaryCompare)
      'def second space position in curVal1
      spacePos2 = InStr(spacePos1 + 1, curVal1, Chr(10), vbBinaryCompare)
      'def first word in curVal1 cell and place it into sheet3
      Worksheets("Sheet3").Cells(lastRow3_1 + step - 1 + x, colNum3) = Mid(curVal1, 1, spacePos1 - 1)
      'def second word in curVal1 cell and place it into sheet3
      Worksheets("Sheet3").Cells(lastRow3_1 + step - 2 + x, colNum3 + 1) = Mid(curVal1, spacePos1 + 1, spacePos2 - spacePos1 - 1)
  
  Next x
  
  'def last row in a new list sheet3
  lastRow3 = Worksheets("Sheet3").Cells(Rows.Count, colNum3).End(xlUp).Row
  'def last row in a new list sheet3
  firstRow3 = Worksheets("Sheet3").Cells(Rows.Count, colNum3).End(xlUp).End(xlUp).Row
  
  'del replicas from list with names and sort in ascend order in sheet3
  With Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(firstRow3, colNum3), Worksheets("Sheet3").Cells(lastRow3, colNum3))
  
      .RemoveDuplicates Columns:=Array(1), Header:=xlNo
      .Sort key1:=Worksheets("Sheet3").Cells(firstRow3, colNum3), Header:=xlNo
  
  End With
  
  'del replicas from list with positions and sort in ascend order in sheet3
  With Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(firstRow3 - 1, colNum3 + 1), Worksheets("Sheet3").Cells(lastRow3, colNum3 + 1))
  
      .RemoveDuplicates Columns:=Array(1), Header:=xlNo
      .Sort key1:=Worksheets("Sheet3").Cells(firstRow3 - 1, colNum3 + 1), Header:=xlNo
  
  End With
  
  'def new last cell for list of positions in sheet3
  lastRow3_2 = Worksheets("Sheet3").Cells(Rows.Count, colNum3 + 1).End(xlUp).Row
  
  'transpose sorted list of items into head row
  Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(firstRow3 - 1, colNum3 + 1), Worksheets("Sheet3").Cells(firstRow3 - 1, lastRow3_2 - firstRow3 + colNum3 + 1)) = Worksheets("Sheet3").Application.Transpose(Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(firstRow3 - 1, colNum3 + 1), Worksheets("Sheet3").Cells(lastRow3_2, colNum3 + 1)))
  Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(firstRow3, colNum3 + 1), Worksheets("Sheet3").Cells(lastRow3_2, colNum3 + 1)).Clear
  
  'def last row in a new list sheet3 after deleting dublicates (need a method of calling a function to do it repeatedly)
  lastRow3n = Worksheets("Sheet3").Cells(Rows.Count, colNum3).End(xlUp).Row
  'loop through list of names
  For namesList = firstRow3 To lastRow3n
  
      For headRow = colNum3 + 1 To lastRow3_2 - firstRow3 + colNum3 + 1
  
          'takes position name of the current position in the head row list
          currentValue = Worksheets("Sheet3").Cells(namesList, colNum3) &amp; Chr(10) &amp; Worksheets("Sheet3").Cells(firstRow3 - 1, headRow) &amp; Chr(42)
          Worksheets("Sheet3").Cells(namesList, headRow).Value = "0.00"                'def starting value
          Worksheets("Sheet3").Cells(namesList, headRow).NumberFormat = "#,##0.00"     'establishes cell format
          'loop through list in the base table
          For firstList = firstRow1 To lastRow1
  
              listValue = Worksheets("Sheet1").Cells(firstList, colNum1).Value
              'checks if value in the first list equal to the current combined value
              If listValue Like currentValue Then
  
                  Worksheets("Sheet3").Cells(namesList, headRow).Value = Worksheets("Sheet3").Cells(namesList, headRow).Value + Worksheets("Sheet1").Cells(firstList, colNum1 + 1).Value
  
              End If
  
          Next firstList
  
      Next headRow
  
  Next namesList
  
  Next per
  
  Application.ScreenUpdating = True                   'turns on dynamic screen update
  Application.Calculation = xlCalculationAutomatic    'turns on automatic formulas
  
  End Sub
  </code></pre>