Code Issue

J

jmk15315

Board Regular
Joined
Nov 7, 2021
Messages
73
Office Version
  1. 2013
  2. 2010
Platform
  1. Windows
I created the following code to create a report for all data in the workbook that works but takes about five minutes to run. I have attached a copy of the code, but I am wondering if someone might have a better way to perform the function. I use a "Call" function to run 24 of this same code (changing search parameters "FG0100" to "FG0200", etc...).

VBA Code: 
Sub IMPORT_FG0100_ALL()

    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim lastRowSource As Long, lastRowDest As Long
    Dim i As Long, j As Long
    Dim cell As Range
    
    ' UNLOCK DESTINATION SHEET
    Sheet152.Unprotect (CAT_PROTECT)

' BEGIN FG0100 =============================================================================================================
    
    ' Set destination worksheet
    Set wsDestination = ThisWorkbook.Worksheets("JIF")
    
    ' Find the last row with data in column A of the destination sheet
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row
    
    ' Enter "FG-0100" into column A of the last row
    Set cell = wsDestination.Cells(lastRowDest + 1, "A")
    cell.value = "FG-0100 ROBOT"
    
    ' Apply formatting: bold and font size 12
    With cell.Font
        .Bold = True
        .Size = 16
    End With
    
' PLATFORM
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Worksheets("PLATFORM-NEW")
    Set wsDestination = ThisWorkbook.Worksheets("JIF")

    ' Find the last row with data in source and destination sheets
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row
    
    ' Loop through each row in the source sheet
    For i = 1 To lastRowSource
        ' Check conditions: Column J = "FG0100" and Column B > 0
        If wsSource.Cells(i, 2).value > 0 And wsSource.Cells(i, 10).value = "FG0100" Then
            ' Copy entire row to destination sheet
            lastRowDest = lastRowDest + 1 ' Next empty row in destination sheet
            For j = 1 To 10 ' Assuming columns A to J are to be copied
                wsDestination.Cells(lastRowDest, j).value = wsSource.Cells(i, j).value
            Next j
        End If
    Next i

    ' Optional: Notify the user when the process is completed
    ' MsgBox "Rows copied to JIF sheet.", vbInformation

' CONTROLS
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Worksheets("CONTROLS-NEW")
    Set wsDestination = ThisWorkbook.Worksheets("JIF")

    ' Find the last row with data in source and destination sheets
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row

    ' Loop through each row in the source sheet
    For i = 1 To lastRowSource
        ' Check conditions: Column J = "FG0100" and Column B > 0
        If wsSource.Cells(i, 2).value > 0 And wsSource.Cells(i, 10).value = "FG0100" Then
            ' Copy entire row to destination sheet
            lastRowDest = lastRowDest + 1 ' Next empty row in destination sheet
            For j = 1 To 10 ' Assuming columns A to J are to be copied
                wsDestination.Cells(lastRowDest, j).value = wsSource.Cells(i, j).value
            Next j
        End If
    Next i

    ' Optional: Notify the user when the process is completed
    ' MsgBox "Rows copied to JIF sheet.", vbInformation

' PROCESS GEAR (IPG)
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Worksheets("PROCESS GEAR - IPG")
    Set wsDestination = ThisWorkbook.Worksheets("JIF")

    ' Find the last row with data in source and destination sheets
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row

    ' Loop through each row in the source sheet
    For i = 1 To lastRowSource
        ' Check conditions: Column J = "FG0100" and Column B > 0
        If wsSource.Cells(i, 2).value > 0 And wsSource.Cells(i, 10).value = "FG0100" Then
            ' Copy entire row to destination sheet
            lastRowDest = lastRowDest + 1 ' Next empty row in destination sheet
            For j = 1 To 10 ' Assuming columns A to J are to be copied
                wsDestination.Cells(lastRowDest, j).value = wsSource.Cells(i, j).value
            Next j
        End If
    Next i

    ' Optional: Notify the user when the process is completed
    ' MsgBox "Rows copied to JIF sheet.", vbInformation

' PROCESS GEAR (NEW)
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Worksheets("PROCESS GEAR-NEW")
    Set wsDestination = ThisWorkbook.Worksheets("JIF")

    ' Find the last row with data in source and destination sheets
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row

    ' Loop through each row in the source sheet
    For i = 1 To lastRowSource
        ' Check conditions: Column J = "FG0100" and Column B > 0
        If wsSource.Cells(i, 2).value > 0 And wsSource.Cells(i, 10).value = "FG0100" Then
            ' Copy entire row to destination sheet
            lastRowDest = lastRowDest + 1 ' Next empty row in destination sheet
            For j = 1 To 10 ' Assuming columns A to J are to be copied
                wsDestination.Cells(lastRowDest, j).value = wsSource.Cells(i, j).value
            Next j
        End If
    Next i

    ' Optional: Notify the user when the process is completed
    ' MsgBox "Rows copied to JIF sheet.", vbInformation

' PROCESS GEAR (STANDARD)
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Worksheets("PROCESS GEAR - STANDARD")
    Set wsDestination = ThisWorkbook.Worksheets("JIF")

    ' Find the last row with data in source and destination sheets
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row

    ' Loop through each row in the source sheet
    For i = 1 To lastRowSource
        ' Check conditions: Column J = "FG0100" and Column B > 0
        If wsSource.Cells(i, 2).value > 0 And wsSource.Cells(i, 10).value = "FG0100" Then
            ' Copy entire row to destination sheet
            lastRowDest = lastRowDest + 1 ' Next empty row in destination sheet
            For j = 1 To 10 ' Assuming columns A to J are to be copied
                wsDestination.Cells(lastRowDest, j).value = wsSource.Cells(i, j).value
            Next j
        End If
    Next i

    ' Optional: Notify the user when the process is completed
    ' MsgBox "Rows copied to JIF sheet.", vbInformation

' TORCH
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Worksheets("TORCH-NEW")
    Set wsDestination = ThisWorkbook.Worksheets("JIF")

    ' Find the last row with data in source and destination sheets
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row

    ' Loop through each row in the source sheet
    For i = 1 To lastRowSource
        ' Check conditions: Column J = "FG0100" and Column B > 0
        If wsSource.Cells(i, 2).value > 0 And wsSource.Cells(i, 10).value = "FG0100" Then
            ' Copy entire row to destination sheet
            lastRowDest = lastRowDest + 1 ' Next empty row in destination sheet
            For j = 1 To 10 ' Assuming columns A to J are to be copied
                wsDestination.Cells(lastRowDest, j).value = wsSource.Cells(i, j).value
            Next j
        End If
    Next i

    ' Optional: Notify the user when the process is completed
    ' MsgBox "Rows copied to JIF sheet.", vbInformation

' MATERIAL FLOW
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Worksheets("MATERIAL FLOW - NEW")
    Set wsDestination = ThisWorkbook.Worksheets("JIF")

    ' Find the last row with data in source and destination sheets
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row

    ' Loop through each row in the source sheet
    For i = 1 To lastRowSource
        ' Check conditions: Column J = "FG0100" and Column B > 0
        If wsSource.Cells(i, 2).value > 0 And wsSource.Cells(i, 10).value = "FG0100" Then
            ' Copy entire row to destination sheet
            lastRowDest = lastRowDest + 1 ' Next empty row in destination sheet
            For j = 1 To 10 ' Assuming columns A to J are to be copied
                wsDestination.Cells(lastRowDest, j).value = wsSource.Cells(i, j).value
            Next j
        End If
    Next i

    ' Optional: Notify the user when the process is completed
    ' MsgBox "Rows copied to JIF sheet.", vbInformation

' MODULAR - NEW
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Worksheets("MODULAR - NEW")
    Set wsDestination = ThisWorkbook.Worksheets("JIF")

    ' Find the last row with data in source and destination sheets
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row

    ' Loop through each row in the source sheet
    For i = 1 To lastRowSource
        ' Check conditions: Column J = "FG0100" and Column B > 0
        If wsSource.Cells(i, 2).value > 0 And wsSource.Cells(i, 10).value = "FG0100" Then
            ' Copy entire row to destination sheet
            lastRowDest = lastRowDest + 1 ' Next empty row in destination sheet
            For j = 1 To 10 ' Assuming columns A to J are to be copied
                wsDestination.Cells(lastRowDest, j).value = wsSource.Cells(i, j).value
            Next j
        End If
    Next i

    ' Optional: Notify the user when the process is completed
    ' MsgBox "Rows copied to JIF sheet.", vbInformation

' CUSTOM
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Worksheets("CUSTOM")
    Set wsDestination = ThisWorkbook.Worksheets("JIF")

    ' Find the last row with data in source and destination sheets
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row

    ' Loop through each row in the source sheet
    For i = 1 To lastRowSource
        ' Check conditions: Column J = "FG0100" and Column B > 0
        If wsSource.Cells(i, 2).value > 0 And wsSource.Cells(i, 10).value = "FG0100" Then
            ' Copy entire row to destination sheet
            lastRowDest = lastRowDest + 1 ' Next empty row in destination sheet
            For j = 1 To 10 ' Assuming columns A to J are to be copied
                wsDestination.Cells(lastRowDest, j).value = wsSource.Cells(i, j).value
            Next j
        End If
    Next i

    ' Optional: Notify the user when the process is completed
    ' MsgBox "Rows copied to JIF sheet.", vbInformation


' END FG0100 ===============================================================================================================
    
    ' UNLOCK DESTINATION SHEET
    Sheet152.Protect (CAT_PROTECT)
    
End Sub
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Sort by date Sort by votes
jmk15315 said:
I use a "Call" function to run 24 of this same code (changing search parameters "FG0100" to "FG0200", etc...).
Click to expand...
You should use one function with an argument that is the search value, then simply amend the argument that you pass to it each time. It would also be a lot faster to use arrays rather than reading cell by cell.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Move Completed cells auto using VBA when they have been changed to completed
Replies
5
Views
360
dmt32
D
P
  • Solved
VBA Code to move entire row of data based on multiple number criteria
2 3 4
Replies
31
Views
841
mumps
mumps
T
  • Solved
VBA code cannot find sheet name
2
Replies
11
Views
935
jolivanes
jolivanes
R
  • Question Question
VBA- Adding source and destination cells together rather than overwriting
Replies
4
Views
245
Alex Blakenburg
A
M
  • Question Question
Split Excel Workbook to separate .xlsx files for each unique value in Column A, also copy worksheet for Drop Down reference
Replies
9
Views
411
Alex Blakenburg
A

Forum statistics

Threads
1,223,214
Messages
6,170,772
Members
452,353
Latest member
strainu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top