running of macro excel "not responding"

CecileRecog · Jun 24, 2015

Hello everyone

after spending quite some time on this forum and finding quite a lot of useful answers, I am coming to you with my problem.

My company (a private clinic) is in need to get some important data on a daily basis. From the software that we use to manage patients, I can run a report that will give me information in the following columns:

[TABLE="width: 704"]
<tbody>[TR]
[TD="class: xl65, width: 64"]Patient[/TD]
[TD="class: xl65, width: 64"]Patient ID[/TD]
[TD="class: xl65, width: 64"]Appointment Date[/TD]
[TD="class: xl65, width: 64"]Appointment Type[/TD]
[TD="class: xl65, width: 64"]Clinician[/TD]
[TD="class: xl65, width: 64"]Appointment charge[/TD]
[TD="class: xl65, width: 64"]Invoice Number[/TD]
[TD="class: xl65, width: 64"]Consulting Room[/TD]
[TD="class: xl65, width: 64"]Appointment End Date/Time[/TD]
[TD="class: xl65, width: 64"][/TD]
[TD="class: xl65, width: 64"][/TD]
[/TR]
</tbody>[/TABLE]

I need to rearrange these to get the important data. On a separate spreadsheet, I have correspondence for all possible appointment type with appointment category and for all possible consulting rooms with "site" (as we operate in more than 1 place). I am very sorry because the code is fairly long and complicated.

My issue is that it takes excel about 45mn to run the whole thing. I have more than 10 000 rows (the report displays all appointments that ever happened), which explains the long time, but 45mn

It takes 100% of the memory when running (I can't do anything else on the computer during that time) and excel keeps going on and off (not responding).

Although I understand that going through more than 10 000 rows of data is a lot to ask excel, any help to make this a bit better would be appreciated.

Here is the code (hoping I am inserting it correctly

) I am happy to send the spreasheet if needed.

Code:

Sub DailyUpdate()'
'


'
    Columns("A:A").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Columns("D:D").Select
    Selection.ColumnWidth = 53.43
    Columns("E:E").EntireColumn.AutoFit
    'resize columns
    
    Range("A7").Select
    ActiveSheet.Name = "GeneralData"
    'change name of the sheet in GeneralData
    
    Range("B6").Select
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B6").Select
    ActiveCell.FormulaR1C1 = "New Blood"
    ' create new column called New Blood
    
    Range("B7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(COUNTIF(R1C1:RC[-1],RC[-1])>1,""OLD"",""NEW""))"
    'fill cell following this rule: look in the previous column (Patient name) from beginning until same number cell (RC[-1]) if you can find the name more than once leave the cell empty if not put the name
    
    Range("B7").Select
    Range("B7:B" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy the formula until last active cell seen in A
    Columns("B:B").EntireColumn.AutoFit
        
    Columns("F:F").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("F6").Select
    ActiveCell.FormulaR1C1 = "Appointment Category"
    'create new column call Appointment Category
    
    Range("F7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]="""","""",LOOKUP(RC[-1],'\\RECOGPC05\Patient Details\Software\
[listdonotdelete.xlsx]Sheet1'!C21,'\\RECOGPC05\Patient Details\Software\
[listdonotdelete.xlsx]Sheet1'!C22))"
    'in cell F7, formula: if the cell in column F is empty, cell G stays empty, if not look for the content in column U of ListDONOTDELETE and fill with corresponding content from column V
    
    Range("F7").Select
    Range("F7:F" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    Columns("F:F").EntireColumn.AutoFit
    'copy the formula until last active cell seen in A and autofit


    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H6").Select
    ActiveCell.FormulaR1C1 = "NEW EVENT Help1"
    'insertion column NEW EVENT Help1
    
    Range("H7").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""","""",RC[-7]&""-""&RC[-1])"
    'formula: combined Patient(RC[-7])-Clinician(RC[-1]) except if Clinician empty, leave empty
    
    Range("H7").Select
    Range("H7:H" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("I6").Select
    ActiveCell.FormulaR1C1 = "NEW EVENT Help2"
    'insertion column NEW EVENT Help2
    
    Range("I7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(COUNTIF(R1C8:RC[-1],RC[-1])>1,""FU"",""NEW""))"
    'formula:if the cell in column H is empty, leave empty, if not look at column H from beginning until same line, if the result appears more than once FU, if not NEW
    
    Range("I7").Select
    Range("I7:I" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("J:J").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("J6").Select
    ActiveCell.FormulaR1C1 = "NEW EVENT Help3"
    'insertion column NEW EVENT Help3
    
    Range("J7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(RC[-4]=""Clinical Trials"",RC[-4]=""Clinical Trials Screening""),RC[-4],RC[-1])"
    'formula:if the cell in column F says Clinical Trials or Clinical Trials Screning, copy this cell otherwise cell in column I
    
    Range("J7").Select
    Range("J7:J" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("K:K").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("K6").Select
    ActiveCell.FormulaR1C1 = "NEW EVENT"
    'insertion column NEW EVENT
    
    Range("K7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(RC[-5]=""Pathology"",RC[-5]=""Imaging""),""Investigation"",RC[-1])"
    'formula: if cell on same line in column F (RC[-5]) says Pathology or Imaging, fill cell with Investigation, if not copy cell column I (RC[-1])
    
    Range("K7").Select
    Range("K7:K" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("H:J").Select
    Range("H4").Activate
    Selection.EntireColumn.Hidden = True
    'hide columns helper columns


    Columns("O:O").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("O6").Select
    ActiveCell.FormulaR1C1 = "SITE"
    'insertion column SITE
    
    Range("O7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]="""","""",LOOKUP(RC[-1],'\\RECOGPC05\Patient Details\Software\
[listdonotdelete.xlsx]Sheet1'!C24,'\\RECOGPC05\Patient Details\Software\
[listdonotdelete.xlsx]Sheet1'!C25))"
    'formula: if cell in column M same line (RC[-1]) is empty, leave empty, if not search cell in column M same line (RC[-1]) in column X in ListDONOTDELETE sheet (C24) and return corresponding cell in column Y (C25)
    
    Range("O7").Select
    Range("O7:O" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "NewBloodLondon"
    'add sheet NewBloodLondon
    
    Sheets("GeneralData").Select
    Columns("D:D").Select
    Selection.NumberFormat = "m/d/yyyy"
    'change format date column to get rid of time


    Range("A:A,B:B,D:D,F:F,L:L,O:O").Select
    Range("O1").Activate
    Selection.Copy
    Sheets("NewBloodLondon").Select
    ActiveSheet.Paste
    Range("B7").Select
    'copy paste relevant columns on sheet NewBloodLondon
       
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("D6").Select
    ActiveCell.FormulaR1C1 = "Date help1"
    'insert column Date help1


    Range("D7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(MONTH(RC[-1])<4,""Q1"",IF(MONTH(RC[-1])>9,""Q4"",IF(AND(MONTH(RC[-1])>3,MONTH(RC[-1])<7),""Q2"",""Q3""))))"
    'formula: determine quarter, leave empty if date empty
    
    Range("D7").Select
    Range("D7:D" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A


    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("E6").Select
    ActiveCell.FormulaR1C1 = "Date help2"
    'insert column Date help2
    
    Range("E7").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-2]="""","""",YEAR(RC[-2]))"
    Range("E7").Select
    Range("E7:E" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    Columns("E:E").Select
    Selection.NumberFormat = "General"
    'formula to get year then copy formula until last active cell seen in A
    
    Columns("F:F").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("F6").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "Date"
    'insert column Date
    
    Range("F7").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-2]="""","""",RC[-2]&""-""&RC[-1])"
    Range("F7").Select
    'combine columns Date help1 and Date help2
    
    Range("F7:F" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("D:E").Select
    Range("D4").Activate
    Selection.EntireColumn.Hidden = True
    'hide columns Date help1 and Date help2


    Columns("F:F").Select
    Selection.Copy
    Range("K1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("K:K").RemoveDuplicates Columns:=1, Header:= _
        xlNo
    Range("K1").Select
    Selection.Delete Shift:=xlUp
    'copy date and remove duplicates


    Columns("G:G").Select
    Selection.Copy
    Range("L1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Columns("L:L").Select
    Application.CutCopyMode = False
    ActiveSheet.Range("L:L").RemoveDuplicates Columns:=1, Header:= _
        xlNo
    ActiveWorkbook.Worksheets("NewBloodLondon").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("NewBloodLondon").Sort.SortFields.Add Key:=Range("L1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("NewBloodLondon").Sort
        .SetRange Range("L:L")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("L1:L2").Select
    Range("L2").Activate
    Selection.Delete Shift:=xlUp
    Range("L1:L200").Select
    Selection.Copy
    Range("M1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    'copy category, remove duplicates and sort by alphabetical order and copy/paste with transcription (to get column in line)
 
    Columns("L:L").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    'suppress column L
    
    Dim i As Long, MaxColumns As Long
    Dim WrongHeaderName As String
    MaxColumns = ActiveSheet.UsedRange.Columns.Count
    WrongHeaderName = "Clinical Trials"
    WrongHeaderName2 = "Clinical Trials Screening"
    For i = MaxColumns To 1 Step -1
        If ActiveSheet.Cells(1, i).Value = WrongHeaderName Then ActiveSheet.Cells(1, i).EntireColumn.Delete xlshiftleft
    Next i
    'suppress column Clinical Trials
    
    Range("L2").Select
    ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT((C6=RC11)*(C7=R1C)*(C9=""London"")*(C2=""NEW""))"
    'formula: sum of all NEW in column G (C7) that meet the criteria 1/column F (C6)=cell same line in column K(RC11) 2/column G (C7)=cell same column line 1 (R1C) and 3/ column I (C9)= London
    
    Range("L2").Select
    Dim LastCol As Long, LastRow As Long
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Cells(Rows.Count, "K").End(xlUp).Row
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    'copy formula in all table
    
    Sheets("NewBloodLondon").Select
    Sheets("NewBloodLondon").Copy After:=Sheets(2)
    Sheets("NewBloodLondon (2)").Select
    Sheets("NewBloodLondon (2)").Name = "NewBloodHH"
    Range("L2").Select
    ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT((C6=RC11)*(C7=R1C)*(C9=""Holly House"")*(C2=""NEW""))"
    Range("L2").Select
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    Range("L19").Select
    'same method to create sheet HH
    
    Sheets("NewBloodHH").Select
    Application.CutCopyMode = False
    Sheets("NewBloodHH").Copy After:=Sheets(3)
    Sheets("NewBloodHH (2)").Select
    Sheets("NewBloodHH (2)").Name = "NewBloodGuildford"
    Range("L2").Select
    ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT((C6=RC11)*(C7=R1C)*(C9=""Guildford"")*(C2=""NEW""))"
    Range("L2").Select
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    'same method to create sheet Guildford
    
    'if Windsor relevant remove the ' in the following paragraph (except this line)
    'Sheets("NewBloodGuildford").Copy After:=Sheets(3)
    'Sheets("NewBloodGuildford (2)").Select
    'Sheets("NewBloodGuildford (2)").Name = "NewBloodWindsor"
    'Range("L2").Select
    'ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT((C6=RC11)*(C7=R1C)*(C9=""Windsor"")*(C2=""NEW""))"
    'Range("L2").Select
    'Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1


    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "NewEventLondon"
    'create sheet NewEventLondon
    
    Sheets("GeneralData").Select
    Range("A:A,D:D,F:F,K:K,L:L,O:O").Select
    Range("O1").Activate
    Selection.Copy
    Sheets("NewEventLondon").Select
    ActiveSheet.Paste
    Range("F7").Select
    'copy paste relevant columns
    
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("C6").Select
    ActiveCell.FormulaR1C1 = "Date help1"
    'insert column Date help1
    
    Range("C7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(MONTH(RC[-1])<4,""Q1"",IF(MONTH(RC[-1])>9,""Q4"",IF(AND(MONTH(RC[-1])>3,MONTH(RC[-1])<7),""Q2"",""Q3""))))"
    'formula: determine quarter, leave empty if date empty
    
    Range("C7").Select
    Range("C7:C" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("D6").Select
    ActiveCell.FormulaR1C1 = "Date help2"
    'insert column Date help2
    
    Range("D7").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-2]="""","""",YEAR(RC[-2]))"
    Range("D7").Select
    Range("D7:D" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    Columns("D:D").Select
    Selection.NumberFormat = "General"
    'formula to get year then copy formula until last active cell seen in A
    
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("E6").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "Date"
    'insert column Date
    
    Range("E7").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-2]="""","""",RC[-2]&""-""&RC[-1])"
    Range("E7").Select
    'combine columns Date help1 and Date help2
    
    Range("E7:E" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("C:D").Select
    Range("C4").Activate
    Selection.EntireColumn.Hidden = True
    'hide columns Date help1 and Date help2


    Columns("E:E").Select
    Selection.Copy
    Range("K1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("K:K").RemoveDuplicates Columns:=1, Header:= _
        xlNo
    Range("K1").Select
    Selection.Delete Shift:=xlUp
    'copy date and remove duplicates
    
    Columns("F:F").Select
    Selection.Copy
    Range("L1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Columns("L:L").Select
    Application.CutCopyMode = False
    ActiveSheet.Range("L:L").RemoveDuplicates Columns:=1, Header:= _
        xlNo
    ActiveWorkbook.Worksheets("NewEventLondon").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("NewEventLondon").Sort.SortFields.Add Key:=Range("L1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("NewEventLondon").Sort
        .SetRange Range("L:L")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("L1:L2").Select
    Range("L2").Activate
    Selection.Delete Shift:=xlUp
    Range("L1:L200").Select
    Selection.Copy
    Range("M1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    'copy category, remove duplicates and sort by alphabetical order and copy/paste with transcription (to get column in line)
 
    For i = MaxColumns To 1 Step -1
        If ActiveSheet.Cells(1, i).Value = WrongHeaderName Or ActiveSheet.Cells(1, i).Value = WrongHeaderName2 Then ActiveSheet.Cells(1, i).EntireColumn.Delete xlshiftleft
    Next i
    'suppress column Clinical Trials and Clinical Trials Screening
    
    Columns("L:L").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    'suppress column L
    
    Range("L2").Select
    ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""London"")*(C7=""NEW""))"
    'formula: sum of all NEW in column G (C7) that meet the criteria 1/column E (C5)=cell same line in column K(RC11) 2/column F (C6)=cell same column line 1 (R1C)and 3/ column I (C9)= London
    
    Range("L2").Select
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Cells(Rows.Count, "K").End(xlUp).Row
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    'copy formula in all table
        
    Sheets("NewEventLondon").Select
    Sheets("NewEventLondon").Copy After:=Sheets("NewEventLondon")
    Sheets("NewEventLondon (2)").Select
    Sheets("NewEventLondon (2)").Name = "FU-InvestigationLondon"
    Range("L2").Select
    ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""London"")*OR(C7=""FU"",C7=""Investigation""))"
    Range("L2").Select
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    Range("L19").Select
    'same method to create sheet FU-Investigation
     
    Sheets("FU-InvestigationLondon").Select
    Sheets("FU-InvestigationLondon").Copy After:=Sheets("FU-InvestigationLondon")
    Sheets("FU-InvestigationLondon (2)").Select
    Sheets("FU-InvestigationLondon (2)").Name = "FU-InvestigationHH"
    Range("L2").Select
    ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""Holly House"")*OR(C7=""FU"",C7=""Investigation""))"
    Range("L2").Select
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    Range("L19").Select
    'same method to create sheet FU-InvestigationHH
    
    Sheets("FU-InvestigationHH").Select
    Sheets("FU-InvestigationHH").Copy After:=Sheets("FU-InvestigationHH")
    Sheets("FU-InvestigationHH (2)").Select
    Sheets("FU-InvestigationHH (2)").Name = "FU-InvestigationGuildford"
    Range("L2").Select
    ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""Guildford"")*OR(C7=""FU"",C7=""Investigation""))"
    Range("L2").Select
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    Range("L19").Select
    'same method to create sheet FU-InvestigationGuildford


    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "ClinicalTrialsLondon"
    Sheets("ClinicalTrialsLondon").Select
    Sheets("ClinicalTrialsLondon").Move After:=Sheets("FU-InvestigationGuildford")
    'create new sheet named ClinicalTrialsLondon after sheet FU-InvestigationGuildford
    
    Sheets("NewEventLondon").Select
    Columns("A:I").Select
    Selection.Copy
    Sheets("ClinicalTrialsLondon").Select
    ActiveSheet.Paste
    'copy column A to I in NewEventLondon and paste in the new sheet
    
    Columns("E:E").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("K1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("K:K").RemoveDuplicates Columns:=1, Header:=xlNo
    Range("K1").Select
    Selection.Delete Shift:=xlUp
    'copy column E in K, remove duplicates and first cell
    
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "Screenings"
    Range("M1").Select
    ActiveCell.FormulaR1C1 = "FU Visits"
    'fill L1 with "Screenings" and M1 with "FU Visits"
    
    Columns("F:F").Select
    Selection.Replace What:="Clinical Trials Screening", Replacement:= _
        "Screenings", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False
    Selection.Find(What:="Clinical Trials", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Replace What:="Clinical Trials", Replacement:="FU Visits", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    'in column F replace the sentence "Clinical Trials Screening" by "Screenings" and the sentence "Clinical Trials" by "FU Visits"
    
    Range("L2").Select
    ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""London""))"
    'formula: sum of all products that meet the criteria 1/column E (C5)=cell same line in column K(RC11) 2/column F (C6)=cell same column line 1 (R1C) and 3/ column I (C9)= London
        
    Range("L2").Select
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Cells(Rows.Count, "K").End(xlUp).Row
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    'copy formula in all table
    
    Sheets("ClinicalTrialsLondon").Select
    Sheets("ClinicalTrialsLondon").Copy After:=Sheets("ClinicalTrialsLondon")
    Sheets("ClinicalTrialsLondon (2)").Select
    Sheets("ClinicalTrialsLondon (2)").Name = "ClinicalTrialsGuildford"
    Range("L2").Select
    ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""Guildford""))"
    Range("L2").Select
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    Range("L19").Select
    'same method to create sheet ClinicalTrialsGuildford
    
    Sheets("GeneralData").Select
    ActiveWindow.SelectedSheets.Visible = False
    'hide tab GeneralData
    
End Sub

Thanks a lot for your help!!!

RoryA · Jun 24, 2015

Your code would work a lot better without all the selecting and activating. For example, instead of this:

Code:

Columns("D:D").Select
    Selection.ColumnWidth = 53.43

you can just use:

Code:

Columns("D:D").ColumnWidth = 53.43

I'd also suggest you add:

Code:

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

after the Sub DailyUpdate line, and this:

Code:

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

before the End Sub.

AFPathfinder · Jun 24, 2015

Test this out before committing to it, but it should be a lot faster.

Code:

Sub DailyUpdate()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Range("A1, C1, E1").EntireColumn.AutoFit
    Columns("D").ColumnWidth = 53.43
    'resize columns
    
    ActiveSheet.Name = "GeneralData"
    'change name of the sheet in GeneralData
    
    Columns("B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B6").FormulaR1C1 = "New Blood"
    ' create new column called New Blood
    
    Range("B7").FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(COUNTIF(R1C1:RC[-1],RC[-1])>1,""OLD"",""NEW""))"
    'fill cell following this rule: look in the previous column (Patient name) from beginning until same number cell (RC[-1]) if you can find the name more than once leave the cell empty if not put the name
    
    Range("B7:B" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy the formula until last active cell seen in A
    Columns("B").EntireColumn.AutoFit
        
    Columns("F").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("F6").FormulaR1C1 = "Appointment Category"
    'create new column call Appointment Category
    
    Range("F7").FormulaR1C1 = _
        "=IF(RC[-1]="""","""",LOOKUP(RC[-1],'\\RECOGPC05\Patient Details\Software\"

[listdonotdelete.xlsx] Sheet1 '!C21,'\\RECOGPC05\Patient Details\Software\

[listdonotdelete.xlsx] Sheet1 '!C22))"
    'in cell F7, formula: if the cell in column F is empty, cell G stays empty, if not look for the content in column U of ListDONOTDELETE and fill with corresponding content from column V
    
    Range("F7:F" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    Columns("F").EntireColumn.AutoFit
    'copy the formula until last active cell seen in A and autofit


    Columns("H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H6").FormulaR1C1 = "NEW EVENT Help1"
    'insertion column NEW EVENT Help1
    
    Range("H7").FormulaR1C1 = "=IF(RC[-1]="""","""",RC[-7]&""-""&RC[-1])"
    'formula: combined Patient(RC[-7])-Clinician(RC[-1]) except if Clinician empty, leave empty
    
    Range("H7:H" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("I").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("I6").FormulaR1C1 = "NEW EVENT Help2"
    'insertion column NEW EVENT Help2
    
    Range("I7").FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(COUNTIF(R1C8:RC[-1],RC[-1])>1,""FU"",""NEW""))"
    'formula:if the cell in column H is empty, leave empty, if not look at column H from beginning until same line, if the result appears more than once FU, if not NEW
    
    Range("I7:I" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("J:J").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("J6").FormulaR1C1 = "NEW EVENT Help3"
    'insertion column NEW EVENT Help3
    
    Range("J7").FormulaR1C1 = _
        "=IF(OR(RC[-4]=""Clinical Trials"",RC[-4]=""Clinical Trials Screening""),RC[-4],RC[-1])"
    'formula:if the cell in column F says Clinical Trials or Clinical Trials Screning, copy this cell otherwise cell in column I
    
    Range("J7:J" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("K").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("K6").FormulaR1C1 = "NEW EVENT"
    'insertion column NEW EVENT
    
    Range("K7").FormulaR1C1 = _
        "=IF(OR(RC[-5]=""Pathology"",RC[-5]=""Imaging""),""Investigation"",RC[-1])"
    'formula: if cell on same line in column F (RC[-5]) says Pathology or Imaging, fill cell with Investigation, if not copy cell column I (RC[-1])
    
    Range("K7:K" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("H:J").EntireColumn.Hidden = True
    'hide columns helper columns




    Columns("O").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("O6").FormulaR1C1 = "SITE"
    'insertion column SITE
    
    Range("O7").FormulaR1C1 = _
        "=IF(RC[-1]="""","""",LOOKUP(RC[-1],'\\RECOGPC05\Patient Details\Software\"

[listdonotdelete.xlsx] Sheet1 '!C24,'\\RECOGPC05\Patient Details\Software\

[listdonotdelete.xlsx] Sheet1 '!C25))"
    'formula: if cell in column M same line (RC[-1]) is empty, leave empty, if not search cell in column M same line (RC[-1]) in column X in ListDONOTDELETE sheet (C24) and return corresponding cell in column Y (C25)
    
    Range("O7:O" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Name = "NewBloodLondon"
    'add sheet NewBloodLondon
    
    Sheets("GeneralData").Activate
    Columns("D:D").NumberFormat = "m/d/yyyy"
    'change format date column to get rid of time




    Range("A1,B1,D1,F1,L1,O1").Copy Destination:=Sheets("NewBloodLondon").Range("A1")
    Sheets("NewBloodLondon").Activate
    'copy paste relevant columns on sheet NewBloodLondon
       
    Columns("D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("D6").FormulaR1C1 = "Date help1"
    'insert column Date help1




    Range("D7").FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(MONTH(RC[-1])<4,""Q1"",IF(MONTH(RC[-1])>9,""Q4"",IF(AND(MONTH(RC[-1])>3,MONTH(RC[-1])<7),""Q2"",""Q3""))))"
    'formula: determine quarter, leave empty if date empty
    
    Range("D7:D" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A




    Columns("E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("E6").FormulaR1C1 = "Date help2"
    'insert column Date help2
    
    Range("E7").FormulaR1C1 = "=IF(RC[-2]="""","""",YEAR(RC[-2]))"
    Range("E7:E" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    Columns("E:E").NumberFormat = "General"
    'formula to get year then copy formula until last active cell seen in A
    
    Columns("F").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("F6").NumberFormat = "General"
    Range("F6").FormulaR1C1 = "Date"
    'insert column Date
    
    Range("F7").FormulaR1C1 = "=IF(RC[-2]="""","""",RC[-2]&""-""&RC[-1])"
    'combine columns Date help1 and Date help2
    
    Range("F7:F" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("D:E").EntireColumn.Hidden = True
    'hide columns Date help1 and Date help2




    Columns("F").Copy
    Range("K1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("K:K").RemoveDuplicates Columns:=1, Header:= _
        xlNo
    Range("K1").Delete Shift:=xlUp
    'copy date and remove duplicates




    Columns("G:G").Copy
    Range("L1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("L:L").RemoveDuplicates Columns:=1, Header:= _
        xlNo
    ActiveWorkbook.Worksheets("NewBloodLondon").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("NewBloodLondon").Sort.SortFields.Add Key:=Range("L1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("NewBloodLondon").Sort
        .SetRange Range("L:L")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("L1:L2").Delete Shift:=xlUp
    Range("L1:L200").Copy
    Range("M1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    'copy category, remove duplicates and sort by alphabetical order and copy/paste with transcription (to get column in line)
 
    Columns("L:L").Delete Shift:=xlToLeft
    'suppress column L
    
    Dim i As Long, MaxColumns As Long
    Dim WrongHeaderName As String
    MaxColumns = ActiveSheet.UsedRange.Columns.Count
    WrongHeaderName = "Clinical Trials"
    WrongHeaderName2 = "Clinical Trials Screening"
    For i = MaxColumns To 1 Step -1
        If ActiveSheet.Cells(1, i).Value = WrongHeaderName Then ActiveSheet.Cells(1, i).EntireColumn.Delete xlshiftleft
    Next i
    'suppress column Clinical Trials
    
    Range("L2").FormulaR1C1 = _
        "=SUMPRODUCT((C6=RC11)*(C7=R1C)*(C9=""London"")*(C2=""NEW""))"
    'formula: sum of all NEW in column G (C7) that meet the criteria 1/column F (C6)=cell same line in column K(RC11) 2/column G (C7)=cell same column line 1 (R1C) and 3/ column I (C9)= London
    
    Dim LastCol As Long, LastRow As Long
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Cells(Rows.Count, "K").End(xlUp).Row
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    'copy formula in all table
    
    Sheets("NewBloodLondon").Copy After:=Sheets(2)
    Sheets("NewBloodLondon (2)").Activate
    Sheets("NewBloodLondon (2)").Name = "NewBloodHH"
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = "=SUMPRODUCT((C6=RC11)*(C7=R1C)*(C9=""Holly House"")*(C2=""NEW""))"
    'same method to create sheet HH
    
    Application.CutCopyMode = False
    Sheets("NewBloodHH").Copy After:=Sheets(3)
    Sheets("NewBloodHH (2)").Activate
    Sheets("NewBloodHH (2)").Name = "NewBloodGuildford"
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = "=SUMPRODUCT((C6=RC11)*(C7=R1C)*(C9=""Guildford"")*(C2=""NEW""))"
    'same method to create sheet Guildford
    
    'if Windsor relevant remove the ' in the following paragraph (except this line)
    'Sheets("NewBloodGuildford").Copy After:=Sheets(3)
    'Sheets("NewBloodGuildford (2)").Select
    'Sheets("NewBloodGuildford (2)").Name = "NewBloodWindsor"
    'Range("L2").Select
    'ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT((C6=RC11)*(C7=R1C)*(C9=""Windsor"")*(C2=""NEW""))"
    'Range("L2").Select
    'Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1




    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "NewEventLondon"
    'create sheet NewEventLondon
    
    Sheets("GeneralData").Select
    Range("A1,D1,F1,K1,L1,O1").EntireColumn.Copy Destination:=Sheets("NewEventLondon").Range("A1")
    Sheets("NewEventLondon").Activate
    'copy paste relevant columns
    
    Columns("C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("C6").FormulaR1C1 = "Date help1"
    'insert column Date help1
    
    Range("C7").FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(MONTH(RC[-1])<4,""Q1"",IF(MONTH(RC[-1])>9,""Q4"",IF(AND(MONTH(RC[-1])>3,MONTH(RC[-1])<7),""Q2"",""Q3""))))"
    'formula: determine quarter, leave empty if date empty
    
    Range("C7:C" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("D6").FormulaR1C1 = "Date help2"
    'insert column Date help2
    
    Range("D7").FormulaR1C1 = "=IF(RC[-2]="""","""",YEAR(RC[-2]))"
    Range("D7:D" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    Columns("D").NumberFormat = "General"
    'formula to get year then copy formula until last active cell seen in A
    
    Columns("E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("E6").NumberFormat = "General"
    Range("E6").FormulaR1C1 = "Date"
    'insert column Date
    
    Range("E7").FormulaR1C1 = "=IF(RC[-2]="""","""",RC[-2]&""-""&RC[-1])"
    'combine columns Date help1 and Date help2
    
    Range("E7:E" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
    'copy formula until last active cell seen in A
    
    Columns("C:D").EntireColumn.Hidden = True
    'hide columns Date help1 and Date help2




    Columns("E").Copy
    Range("K1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("K:K").RemoveDuplicates Columns:=1, Header:= _
        xlNo
    Range("K1").Delete Shift:=xlUp
    'copy date and remove duplicates
    
    Columns("F").Copy
    Range("L1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("L:L").RemoveDuplicates Columns:=1, Header:= _
        xlNo
    ActiveWorkbook.Worksheets("NewEventLondon").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("NewEventLondon").Sort.SortFields.Add Key:=Range("L1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("NewEventLondon").Sort
        .SetRange Range("L:L")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("L1:L2").Delete Shift:=xlUp
    Range("L1:L200").Copy
    Range("M1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    'copy category, remove duplicates and sort by alphabetical order and copy/paste with transcription (to get column in line)
 
    For i = MaxColumns To 1 Step -1
        If ActiveSheet.Cells(1, i).Value = WrongHeaderName Or ActiveSheet.Cells(1, i).Value = WrongHeaderName2 Then ActiveSheet.Cells(1, i).EntireColumn.Delete xlshiftleft
    Next i
    'suppress column Clinical Trials and Clinical Trials Screening
    
    Columns("L").Delete Shift:=xlToLeft
    'suppress column L
    
    Range("L2").FormulaR1C1 = _
        "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""London"")*(C7=""NEW""))"
    'formula: sum of all NEW in column G (C7) that meet the criteria 1/column E (C5)=cell same line in column K(RC11) 2/column F (C6)=cell same column line 1 (R1C)and 3/ column I (C9)= London
    
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Cells(Rows.Count, "K").End(xlUp).Row
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    'copy formula in all table
        
    Sheets("NewEventLondon").Copy After:=Sheets("NewEventLondon")
    Sheets("NewEventLondon (2)").Activate
    Sheets("NewEventLondon (2)").Name = "FU-InvestigationLondon"
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""London"")*OR(C7=""FU"",C7=""Investigation""))"
    'same method to create sheet FU-Investigation
     
    Sheets("FU-InvestigationLondon").Copy After:=Sheets("FU-InvestigationLondon")
    Sheets("FU-InvestigationLondon (2)").Activate
    Sheets("FU-InvestigationLondon (2)").Name = "FU-InvestigationHH"
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""Holly House"")*OR(C7=""FU"",C7=""Investigation""))"
    'same method to create sheet FU-InvestigationHH
    
    Sheets("FU-InvestigationHH").Copy After:=Sheets("FU-InvestigationHH")
    Sheets("FU-InvestigationHH (2)").Activate
    Sheets("FU-InvestigationHH (2)").Name = "FU-InvestigationGuildford"
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""Guildford"")*OR(C7=""FU"",C7=""Investigation""))"
    'same method to create sheet FU-InvestigationGuildford




    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "ClinicalTrialsLondon"
    Sheets("ClinicalTrialsLondon").Activate
    Sheets("ClinicalTrialsLondon").Move After:=Sheets("FU-InvestigationGuildford")
    'create new sheet named ClinicalTrialsLondon after sheet FU-InvestigationGuildford
    
    Sheets("NewEventLondon").Activate
    Columns("A:I").Copy Destination:=Sheets("ClinicalTrialsLondon").Range("A1")
    Sheets("ClinicalTrialsLondon").Activate
    'copy column A to I in NewEventLondon and paste in the new sheet
    
    Columns("E").Copy
    Range("K1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("K:K").RemoveDuplicates Columns:=1, Header:=xlNo
    Range("K1").Delete Shift:=xlUp
    'copy column E in K, remove duplicates and first cell
    
    Range("L1").FormulaR1C1 = "Screenings"
    Range("M1").FormulaR1C1 = "FU Visits"
    'fill L1 with "Screenings" and M1 with "FU Visits"
    
    Columns("F").Replace What:="Clinical Trials Screening", Replacement:= _
        "Screenings", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False
    Columns("F").Find(What:="Clinical Trials", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Columns("F").Replace What:="Clinical Trials", Replacement:="FU Visits", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    'in column F replace the sentence "Clinical Trials Screening" by "Screenings" and the sentence "Clinical Trials" by "FU Visits"
    
    Range("L2").FormulaR1C1 = _
        "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""London""))"
    'formula: sum of all products that meet the criteria 1/column E (C5)=cell same line in column K(RC11) 2/column F (C6)=cell same column line 1 (R1C) and 3/ column I (C9)= London
        
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Cells(Rows.Count, "K").End(xlUp).Row
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = Range("L2").FormulaR1C1
    'copy formula in all table
    
    Sheets("ClinicalTrialsLondon").Copy After:=Sheets("ClinicalTrialsLondon")
    Sheets("ClinicalTrialsLondon (2)").Activate
    Sheets("ClinicalTrialsLondon (2)").Name = "ClinicalTrialsGuildford"
    Range("L2", Cells(LastRow, LastCol)).FormulaR1C1 = "=SUMPRODUCT((C5=RC11)*(C6=R1C)*(C9=""Guildford""))"
    'same method to create sheet ClinicalTrialsGuildford
    
    Sheets("GeneralData").Activate
    ActiveWindow.SelectedSheets.Visible = False
    'hide tab GeneralData
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "Done."
End Sub

CecileRecog · Jun 24, 2015

Hi

thanks a lot for your help.

RoryA said:
Your code would work a lot better without all the selecting and activating. For example, instead of this:

Rich (BB code):

Columns("D:D").Select Selection.ColumnWidth = 53.43

you can just use:

Rich (BB code):

Columns("D:D").ColumnWidth = 53.43

It definitely makes the code a lot better and clearer, but doesn't change a lot in term of time unfortunately.

RoryA said:
I'd also suggest you add:

Rich (BB code):

With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With

It is indeed very quick with this, but also not really working... When I do this

Code:

[COLOR=#333333]Range("B7").Select[/COLOR]    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(COUNTIF(R1C1:RC[-1],RC[-1])>1,""OLD"",""NEW""))"
    'fill cell following this rule: look in the previous column (Patient name) from beginning until same number cell (RC[-1]) if you can find the name more than once leave the cell empty if not put the name
    
    Range("B7").Select
    Range("B7:B" & Range("A" & Rows.Count).End(xlUp).Row).FillDown [COLOR=#333333]    'copy the formula until last active cell seen in A[/COLOR]

it does fill all the cells with the formula but doesn't do the calculation. So it returns the value of the first cell all the way down... AFPathfinder same problem with your solution, it doesnt do the calculations...

RoryA · Jun 24, 2015

You did include the additional code lines at the end that turn the calculation back on, didn't you?

CecileRecog · Jun 24, 2015

yes I did

RoryA · Jun 24, 2015

Ahh, I didn't look at all of your code and missed that you are copying the values to new sheets - you need to turn calculation back to automatic before the first line that copies and uses pastespecial - Values.

CecileRecog · Jun 24, 2015

but the issue is not about copying onto new sheets because it doesnt work even on the first sheet... the issue is with the .FillDown

RoryA · Jun 24, 2015

If you're stepping through the code, calculation will be on manual so you will see the same value in all rows after the FillDown line runs, but it will recalculate at the end.

CecileRecog · Jun 24, 2015

okay so I tried this, it is better but it is still going on and off of not responding and using all my memory

It is really annoying and I hope there is a solution. I know that the alternative would be to use access as going through 10 000 rows is a lot for excel but I am not familiar with access...

running of macro excel "not responding"

CecileRecog

New Member

RoryA

MrExcel MVP, Moderator

AFPathfinder

Well-known Member

CecileRecog

New Member

RoryA

MrExcel MVP, Moderator

CecileRecog

New Member

RoryA

MrExcel MVP, Moderator

CecileRecog

New Member

RoryA

MrExcel MVP, Moderator

CecileRecog

New Member

Similar threads

Forum statistics

Share this page

running of macro excel "not responding"

New Member

MrExcel MVP, Moderator

Well-known Member

New Member

MrExcel MVP, Moderator

New Member

MrExcel MVP, Moderator

New Member

MrExcel MVP, Moderator

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock