excelvba

Excel crashes when copying columns with vba


I'm writing a macro that opens an Excel file (.xlsx) with 6300 rows and 73 columns (the rows number is not always the same because this file is a report) and copies some columns (choosen by the user and stored in an array called stringArray) in the second sheet of the current .xlsm workbook (the workbook where I'm running the macro). The code works almost as expected if I make an assegnment using .Value but without the column formatting of the source file (colored columns and borders).

If I use the .copy method without .Value Excel locks and I have to terminate it from task manager.

stringArray is an array populated with the content of a cell and contains "D, E, G, F, K, L, M, Q, R, S, U, V, W, X, Z, AD, AE, AF, AH, AJ, AK, AL, AM, AW, AX"

What am I doing wrong?

Thanks

SOLVED: the problem was a useless declaration of a new excel instance: Dim app As New Excel.Application

Dim SrcColsRange As String
Dim DestColsRange As String
Dim Col_char1 As String
Dim app As New Excel.Application

app.Visible = False

Set srcWorkbook = app.Workbooks.Open(FileNameSrc)

L = LBound(stringArray)
U = UBound(stringArray)
ThisWorkbook.Worksheets(2).Cells.Clear

For x = L To U
    ''''''''' Col_Letter RETURNS THE COLUMN LETTER FROM 1 (x+1) TO n (NUMBER OF COLUMNS PRESENT IN stringArray)
    Col_char1 = Col_Letter(x + 1)
    SrcColsRange = stringArray(x) & ":" & stringArray(x)
    DestColsRange = Col_char1 & ":" & Col_char1
    
    ''''''''' IT WORKS BUT WITHOUT SOURCE FILE FORMATTING '''''''''
    ThisWorkbook.Worksheets(2).Range(DestColsRange).Value = srcWorkbook.Sheets(1).Range(SrcColsRange).Value
    
    ''''''''' IT DOESN'T WORK AND LOCKS EXCEL '''''''''
    srcWorkbook.Sheets(1).Range(SrcColsRange).Copy Destination:=ThisWorkbook.Worksheets(2).Range(DestColsRange)
    
Next x

srcWorkbook.Close
MsgBox "File imported successfully!", vbInformation, "Finito!"

Solution

  • Please, try the next adapted code. It uses arrays to rapidly copy values and Application.Index function which is able to extract specific columns of the array (in a different order, if necessary...).

    Then, it copies format, which takes longer, but it shouldn't kill Excel:

    Sub ImportData()
     Dim FileNameSrc As String, SrcColsRange As String, lastRow As Long, arr, arrColNo, arrFin, x As Long
     Dim srcWorkbook As Workbook, wsSrc As Worksheet, wsDest As Worksheet, rngCopy As Range, stringArray
     Const strCols As String = "D, E, G, F, K, L, M, Q, R, S, U, V, W, X, Z, AD, AE, AF, AH, AJ, AK, AL, AM, AW, AX"
     
     stringArray = Split(strCols, ", ")
     
     FileNameSrc = "your Workbook to import from full name" 'Please, use here the real full name!
     Set srcWorkbook = Workbooks.Open(FileNameSrc)
     Set wsSrc = srcWorkbook.Sheets(1)
     lastRow = wsSrc.Range("A1").SpecialCells(xlCellTypeLastCell).Row 'last row of the larger column
     
     Set rngCopy = wsSrc.Range("A1:" & stringArray(UBound(stringArray)) & lastRow) 'set the range to be processed
     arr = rngCopy.Value   'place the range to be processed in an array
    
     arrColNo = getArrColsNo(strCols, ", ") 'load an array of necessary columns to be returned NUMBERS
     
     arrFin = Application.Index(arr, Evaluate("row(1:" & UBound(arr) & ")"), arrColNo) ' The necessary final array!
    
     Set wsDest = wsSrc.Next     ' ThisWorkbook.Worksheets(2) 'set the destination sheet
     wsDest.cells.ClearContents  'clear the destination sheet contents
     
     'drop the final array content, at once and AutoFit the dropped columns:
     With wsDest.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
        .Value = arrFin
        .EntireColumn.AutoFit
     End With
     
     'copy each column format (this part will take some time...):
     Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
      For x = 0 To UBound(arrColNo)
        rngCopy.Columns(arrColNo(x)).Copy
        wsDest.cells(1, x + 1).PasteSpecial xlPasteFormats 'paste only the format of the copied column
      Next x
     Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
     
     wsDest.Activate 'activate the destination sheet...
    
     srcWorkbook.Close
     MsgBox "File imported successfully!", vbInformation, "Finito!"
    End Sub
    

    Please, send some feedback after testing it.