Excel VBA Macro Shut Down

Hi KI

Re, ".... Is the repeating code the problem? Or is it an overload problem? "

Well .., Sort of,

Notes:

1. Please, Avoid using SELECT, SELECTION, ACTIVECELLwhen coding. It is slow and error-prone. Always refer to the objects directly.
2. It is not clear Which workbook/file you are running the macro from.

a) How many workbooks are you working with, when running the macro?

b) What is the name of the workbook you run the macro from?

3. It is not fully clear to me on the 2nd part of the code when you activate the "CLIST.xlsx" workbook ( from the Windows("CLIST.xlsx").Activate line downwards)

I do not see the purpose of having those lines inside the loop.

4. As our colleague Nothing Left to Lose mentioned

"...select and add a custom number format to ~17 billion cells on each sheet."

That's A LOT, my friend

5. The following code use VBA arrays to speed up the loop process.

Sub FixDataTable()

Dim ws As Worksheet

Dim HARN As Variant

Dim WIRE As Variant

Dim SQUA As Variant

Dim COL As Variant

Dim MAT As Variant

Dim F_CONNECTOR As Variant

Dim T_CONNECTOR As Variant

Dim F_PIN As Variant

Dim T_PIN As Variant

Dim T1 As Variant

Dim T2 As Variant

Dim APPCODE As Variant

Dim REMARKS As Variant

Dim CLIST As Variant

Dim copyRng As Variant

Application.ScreenUpdating = False

For Each ws In Worksheets

If ws.Name <> "KEY" Then

With ws

''' Populate the arrays with the data 

    HARN = .Range("A1:A2000") 

    WIRE = .Range("B1:B2000") 

    SQUA = .Range("C1:C2000") 

    COL = .Range("D1:D2000") 

    MAT = .Range("E1:E2000") 

    F\_CONNECTOR = .Range("F1:F2000") 

    F\_PIN = .Range("G1:G2000") 

    T1 = .Range("H1:H2000") 

    T\_CONNECTOR = .Range("I1:I2000") 

    T\_PIN = .Range("J1:J2000") 

    T2 = .Range("K1:K2000") 

    APPCODE = .Range("L1:L2000") 

    REMARKS = .Range("N1:N2000") 

    .Range("A1:N2000").ClearContents  ''' This line clear/deletes the source data table 

    ''' Paste back the data in their relevant columns 

    .Range("A1:A2000") = HARN 

    .Range("B1:B2000") = WIRE 

    .Range("C1:C2000") = F\_CONNECTOR 

    .Range("D1:D2000") = F\_CONNECTOR 

    .Range("E1:E2000") = F\_PIN 

    .Range("F1:F2000") = F\_CONNECTOR 

    .Range("G1:G2000") = SQUA 

    .Range("H1:H2000") = COL 

    .Range("I1:I2000") = T\_CONNECTOR 

    .Range("J1:J2000") = T\_CONNECTOR 

    .Range("K1:K2000") = T\_PIN 

    .Range("L1:L2000") = T\_CONNECTOR 

    .Range("O1:O2000") = MAT 

    .Range("P1:P2000") = T1 

    .Range("Q1:Q2000") = T2 

    .Range("S1:S2000") = REMARKS 

   ''' This line inserts the new Headers in one go 

   .Range("A1:U1").Value = Array("HARN", "WIRE", "FROM\_CONNECTOR", "FROM\_CONNECTOR", "FROM\_PIN", "FROM\_CONNECTOR", "SQUA", "COL", "TO\_CONNECTOR", "TO\_CONNECTOR", "TO\_PIN", "TO\_CONNECTOR", "J/S", "APPCODE", "MAT", "T1", "T2", "REV", "REMARKS", "JOINT", "JOINT") 

End With

'''''''''******PART 2*************************PART2**********'''''*****************PART2***************************************PART2*********

Windows("CLIST.xlsx").Activate

copyRng = Range("A3:H500")

Windows("WLIST.xlsm").Activate

Range("V2:AC499") = copyRng

Range("V2:AC499").NumberFormatLocal = "G/??"

Range("D2", Range("D2").End(xlDown)).FormulaR1C1 = "=INDEX(C[18],MATCH(RC[-1],C[19],0),0)"

Range("F2", Range("F2").End(xlDown)).FormulaR1C1 = "=INDEX(C[19],MATCH(RC[-3],C[17],0),0)"

Range("J2", Range("J2").End(xlDown)).FormulaR1C1 = "=INDEX(C22,MATCH(RC[-1],C23,0),0)"

Range("L2", Range("L2").End(xlDown)).FormulaR1C1 = "=INDEX(C25,MATCH(RC[-3],C23,0),0)"

End If

Next ws

Application.ScreenUpdating = True

End Sub

I hope this helps you and gives a solution to your problem

Do let me know if you need more help

Regards

Jeovany