Consulting

Results 1 to 6 of 6

Thread: Is it possible to make it faster? VBA copy and paste when condition is met

  1. #1
    VBAX Regular
    Joined
    Nov 2020
    Posts
    7
    Location

    Is it possible to make it faster? VBA copy and paste when condition is met

    Hi!

    I have a problem with macro running too slow and I guess it is just because of lack of my knowledge.

    I have a macro that is copying data from "database" and paste it to another sheet.
    Macro is taking the names from the list in Sheet1 and looks for matches in Sheet2. When the match is found is copying a specific cell.

    Right now I have a macro for each person on the list so I have 5 the same macros doing the same thing so maybe that why it takes so much time....

    Is there any way to make it faster?
    below my code so far and sample sheet

    Sub CopySalesMan1()
    
    
    Dim lastrow As Long, erow As Long
    
    
    lastrow = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row
    
    
    For i = 2 To lastrow
    
    
    If Worksheets("Sheet2").Cells(i, 25).Value = Worksheets("Sheet1").Cells(6, 12).Value Then
    
    
        Worksheets("Sheet2").Cells(i, 2).Copy
    
    
        erow = Worksheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row
    
    
        Worksheets("Sheet1").Cells(erow + 1, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    
    
        Worksheets("Sheet2").Cells(i, 25).Copy
    
    
        Worksheets("Sheet1").Cells(erow + 1, 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        Worksheets("Sheet2").Cells(i, 3).Copy
    
    
        Worksheets("Sheet1").Cells(erow + 1, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        Worksheets("Sheet2").Cells(i, 4).Copy
    
    
        Worksheets("Sheet1").Cells(erow + 1, 6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            
            
        Worksheets("Sheet2").Cells(i, 5).Copy
    
    
        Worksheets("Sheet1").Cells(erow + 1, 7).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            
            
        Worksheets("Sheet2").Cells(i, 6).Copy
    
    
        Worksheets("Sheet1").Cells(erow + 1, 8).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            
        Worksheets("Sheet2").Cells(i, 21).Copy
    
    
        Worksheets("Sheet1").Cells(erow + 1, 9).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    
    
    
    
    
    
    
    
    End If
    
    
    Next i
    
    
    End Sub
    Sub All()
    
    If Worksheets("Sheet1").Range("L7").Value <> "" Then Call CopySalesMan2
    If Worksheets("Sheet1").Range("L8").Value <> "" Then Call CopySalesMan3
    If Worksheets("Sheet1").Range("L9").Value <> "" Then Call CopySalesMan4
    If Worksheets("Sheet1").Range("L10").Value <> "" Then Call CopySalesMan5
    
    
    
    
    End Sub
    Example Sheet.xlsm

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Perhaps:

    Sub CopySalesMan()
    Application.ScreenUpdating = False
    Dim XlWkSht As Worksheet, sVal As String, lRow As Long, i As Long, r As Long
    Set XlWkSht = Worksheets("Sheet1")
    lRow = XlWkSht.Range("D" & XlWkSht.Rows.Count).End(xlUp).Row
    For i = 6 To 10
      If XlWkSht.Range("L" & i).Value <> "" Then
         sVal = XlWkSht.Range("L" & i).Value
        With Worksheets("Sheet2")
          For r = 2 To .Range("B" & .Rows.Count).End(xlUp).Row
            If .Range("Y" & r).Text = sVal Then
              lRow = lRow + 1
              XlWkSht.Range("C" & lRow).Value = .Range("B" & r).Value
              XlWkSht.Range("D" & lRow).Value = .Range("Y" & r).Value
              XlWkSht.Range("E" & lRow).Value = .Range("C" & r).Value
              XlWkSht.Range("F" & lRow).Value = .Range("D" & r).Value
              XlWkSht.Range("G" & lRow).Value = .Range("E" & r).Value
              XlWkSht.Range("H" & lRow).Value = .Range("F" & r).Value
              XlWkSht.Range("I" & lRow).Value = .Range("U" & r).Value
            End If
          Next r
        End With
      End If
    Next
    Application.ScreenUpdating = True
    End Sub
    Last edited by macropod; 01-15-2021 at 09:26 PM.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  3. #3
    VBAX Regular
    Joined
    Nov 2020
    Posts
    7
    Location
    Yes! that helped a lot!

    macro running time dropped from 220s to 26s!

  4. #4
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    Which is still ridiculously slow.

    Sub CopySalesMan1()
       With Sheets("sheet2").Cells(1).CurrentRegion
          .AutoFilter 25, Sheets("Sheet1").Cells(6, 12)
          .Offset(1).Copy Sheets("Sheet1").Cells(Rows.Count, 4).Offset(1, -1)
          .AutoFilter
       End With
    End Sub

  5. #5
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Quote Originally Posted by snb View Post
    Which is still ridiculously slow.

    Sub CopySalesMan1()
       With Sheets("sheet2").Cells(1).CurrentRegion
          .AutoFilter 25, Sheets("Sheet1").Cells(6, 12)
          .Offset(1).Copy Sheets("Sheet1").Cells(Rows.Count, 4).Offset(1, -1)
          .AutoFilter
       End With
    End Sub
    Way better than useless code that:
    (a) doesn't work at all; and
    (b) even if it did work, doesn't address the OP's requirements.

    In any event, even with 100 data rows to process, my code takes less than 1 second to complete on my laptop. I have no idea why it might take so long on the OP's system.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  6. #6
    VBAX Regular
    Joined
    Nov 2020
    Posts
    7
    Location
    Well the code is a part of a bigger macro so probably that's why it is taking more time than on yours.

    I changed a little bit the rest of the code and I was able to go to 16s

    P.S original data has around 5k rows...

    Anyway thanks for help!

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •