loop of death - need help RRS feed

  • Question

  • Hi there, 

    I'm very new to vba but I managed to write a macro what does the job. But it takes ages of time. 

    So I was wondering if some of you guys can give me a helping hand. My two main problems are, it takes up to 7 hours to import all the data needed and it blocks the computer for the whole time as uses the clipboard and I'm not able to bypass it by direct copy.

    Option Explicit
    Sub import()
    Dim bk As Workbook
    Dim sh As Worksheet, asheet As Worksheet
    Dim sSkill As Range, pval As Range, lstZelle As Range, target As Range, stype As Range, lstZelle1 As Range
    Dim strSuchwort As String, sDate As String, sPath As String, sName As String, strSuchwort1 As String, strSuchwort2 As String
    Dim row As Integer, col As Integer
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    sPath = "C:\Users\*******\test\" 
    sName = Dir(sPath & "*.xl*")
    Do While sName <> ""
    Set bk = Workbooks.Open(sPath & sName)
    sh.Range("A1").AutoFilter field:=1, Criteria1:="<>"
    For Each lstZelle In sh.Range("B:B")
    If lstZelle <> "" Then
    strSuchwort = lstZelle & "*"
    strSuchwort2 = lstZelle.Offset(0, -1)
        For Each lstZelle1 In sh.Range("C:C")
        If lstZelle1 <> "" Then
        strSuchwort1 = lstZelle1
            For Each asheet In ActiveWorkbook.Worksheets
            If asheet.Name = strSuchwort2 Then
                For Each sSkill In Range("A:A")
                If UCase(sSkill) Like UCase(strSuchwort) Then
                sDate = Right(sSkill, 10)
                    For Each stype In Range(sSkill.Offset(1, 0), sSkill.Offset(1, 100))
                    If UCase(stype) Like UCase(strSuchwort1) Then
                    Range(stype.Offset(1, 0), stype.End(xlDown)).copy
                        For Each pval In sh.Range("1:1")
                        If pval = sDate Then
                        col = pval.Column
                        row = lstZelle.row
                        sh.Cells(row, col).PasteSpecial xlPasteValues
                        End If
                        Next pval
                    End If
                    Next stype
                End If
                Next sSkill
            End If
            Next asheet
        End If
        Next lstZelle1
    End If
    Next lstZelle
    bk.Close SaveChanges:=False
    sName = Dir()
    Application.ScreenUpdating = True
    sh.AutoFilterMode = False
    End Sub

    So any help or suggestions would be realy appreciate. I spent already days to get so far, but as it would be block the computer for 7 hours, its simply not practicable.

    EDIT: tried to upload some pictures showing the layout of my the source and target file, but it doesnt seem to be possible until my account has been verified :(

    I hope anyone can provide me with some quick fixes anyway until my account has been verified

    Monday, March 20, 2017 1:47 PM

All replies

  • The code that you have written is obviously dependent on the structure of the workbooks that you are using (you are using .End(xlDown) before copying, so you must have a lot of blocks of data).

    Better than just showing us your code would be describing your workbooks - like, what do you have on the activesheet, what is actually in all the files you are processing (and their structure) - and what you want to actually achieve with your code.

    Monday, March 20, 2017 2:38 PM
  • Hello As Bernie suggested below, if you could describe your workbook layout and what you wish the code to achieve, we will be better able to assist. 

    As a general note, using the clipboard and interacting with a worksheet should be avoided as it vastly increases processing time. Where possible, you should collect data in an Array, process them in memory (as an array), then print them to the workbook. This will likely reduce your processing time significantly. 


    Saturday, April 8, 2017 8:22 PM