Help to speed up VBA when Multiple Checkboxes on a Workbook to copy row data

[malou]

Hi,

I have worksheet with checkboxes on each row that when enabled, the row data will be copied on a master file. This works well, however, vba runs slowly even I turn off excel applications.

I duplicate the codes for each checkboxes changing only the range of the rows to copy. I want to have one code instead of duplicating the codes for each checkbox. If you can help me shorten the code, might help to speed up my vba.

This is the code I use for each checkboxes:

Private Sub CheckBox1_Click()Dim wsTarget As Workbook
Dim wsSource As Workbook
Dim rngSource As Range
Dim rngTarget As Range
Dim wbname As String


With Excel.Application
    .ScreenUpdating = False
    .Calculation = Excel.xlCalculationManual
End With




wbname = "C:\Users\IT SUPPORT\Documents\Blotter\Master.xlsm"


Set wsSource = ActiveWorkbook
Set wsTarget = Workbooks.Open(wbname)
Worksheets("Master").Select
Worksheets("Master").Range("B6").Select






Set rngSource = wsSource.Sheets("Blotter").Range("B7:N7")
Set rngTarget = Worksheets("Master").Range("B" & (Worksheets("Master").Range("B65536").End(xlUp).Row + 1))


If CheckBox1.Value = True Then


rngSource.Copy
rngTarget.PasteSpecial xlPasteValues
wsSource.Worksheets("Blotter").Activate


End If


wsTarget.Close True


With Excel.Application
    .ScreenUpdating = True
    .Calculation = Excel.xlAutomatic
    .CutCopyMode = False
    
End With


End Sub

 

[BrianM45]

Hy

Help to speed up VBA when Multiple Checkboxes on a Workbook to copy row data

Delete all checkboxes and replaces it with cross in cell

With code in sheet

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  ' If you want cross in column C
  If Not Intersect(Range("C:C"), Target) Is Nothing Then
    Cancel = True
    If Target.Value = "" Then
      Target.Value = "X"
      '
      Call OtherCode
    Else
      Target.Value = ""
    End If
  End If
End Sub

This code in module

Sub OtherCode()
  Dim wsTarget As Workbook  Dim wsSource As Workbook
  Dim rngSource As Range
  Dim rngTarget As Range
  Dim wbname As String
  With Excel.Application
    .ScreenUpdating = False
    .Calculation = Excel.xlCalculationManual
  End With
  wbname = "C:\Users\IT SUPPORT\Documents\Blotter\Master.xlsm"
  Set wsSource = ActiveWorkbook
  Set wsTarget = Workbooks.Open(wbname)
  Worksheets("Master").Select
  Worksheets("Master").Range("B6").Select
  Set rngSource = wsSource.Sheets("Blotter").Range("B7:N7")
  Set rngTarget = Worksheets("Master").Range("B" & (Worksheets("Master").Range("B65536").End(xlUp).Row + 1))
  rngSource.Copy
  rngTarget.PasteSpecial xlPasteValues
  wsSource.Worksheets("Blotter").Activate
  wsTarget.Close True
  With Excel.Application
    .ScreenUpdating = True
    .Calculation = Excel.xlAutomatic
    .CutCopyMode = False
  End With
  ' Erase object variable for memory
  Set wsTarget = Nothing: Set wsSource = Nothing
  Set rngSource = Nothing: Set rngTarget = Nothing
  Set wbname = Nothing
End Sub

Regards

 

[malou]

Hi!

Thank you for your immediate response..I'd tried the code and it's not working on my part...I maybe doing it wrong..
as instructed, I deleted all checkboxes and replaced it with "X" on all rows of column "O". Copied and paste the codes above in sheet and module...also, do I need to change the rows to cope on below code?

Set rngSource = wsSource.Sheets("Blotter").Range("B7:N7")

 

[malou]

hi... I tried it again and understand the code.... however, when I double click on the row to copy, column "O", i got a compile error; object required..highlighting the Sub Othercode() and set wbname = nothing

 

[MARK858]

Remove the line, wbname is a string not an object. (I haven't read the rest of the code)

 

[malou]

hi Mark858,

yes, I removed the line and the code works.. my question now is do I need to replace the source code...

Set rngSource = wsSource.Sheets("Blotter").Range("B7:N7")

when the user clicks on the row in column "O", the data on that row should be transferred to a master file.

My problem initially, is to eliminate the duplication of code for each row.. like

if I want to copy... Set rngSource = wsSource.Sheets("Blotter").Range("B6:N6") to master file
then... Set rngSource = wsSource.Sheets("Blotter").Range("B10:N10") an so on... the source range changes...

 

[MARK858]

Does the below help at all (untested). Please note I am assuming that the X's start in row 7 which is why I am using row 6 as I need a row above the range (adjust if different).

Sub OtherCode2()
    Dim wsTarget As Worksheet, wsSource As Worksheet
    Dim wbname As String, rngTarget As Worksheet

    With Excel.Application
        .ScreenUpdating = False
        .Calculation = Excel.xlCalculationManual
    End With

    wbname = "C:\Users\IT SUPPORT\Documents\Blotter\Master.xlsm"
    Set wsSource = ActiveWorkbook.Sheets("Blotter")
    Set wsTarget = Workbooks.Open(wbname)
    Set rngTarget = wsTarget.Worksheets("Master")

    With wsSource.Range("B6:O" & wsSource.Range("O" & Rows.Count).End(xlUp).Row)
        .AutoFilter Field:=14, Criteria1:="X"
        .Offset(1).Resize(.Rows.Count - 1, .Columns.Count - 1).SpecialCells(xlCellTypeVisible).Copy
        rngTarget.Range("b" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        .AutoFilter
    End With



    With Excel.Application
        .ScreenUpdating = True
        .Calculation = Excel.xlAutomatic
    End With
    ' Erase object variable for memory
    Set wsTarget = Nothing
    Set wsSource = Nothing
    Set rngTarget = Nothing

End Sub