Code at present only runs if cell A6 is selected

[ipbr21054]

Morning,
Working code in use is shown below.
Currently the code runs when the cell A6 is selected & command button is used.

Should i not require to be restricted to the cell A6 BUT just any cell in column A then use the command button please advise how i edit the code shown in Red below for this to work.

Thanks

Private Sub Kdx2_Click()
    
    Dim WB As Workbook, DestWB As Workbook
    Dim ws As Worksheet, DestWS As Worksheet
    Dim rng As Range, rngDest As Range
    Dim ColArr As Variant, SCol As Variant, DCol As Variant
 
    On Error Resume Next
    Set DestWB = Application.Workbooks("CLONING-KDX2.xlsm")

    If DestWB Is Nothing Then
        Workbooks.Open fileName:="C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\CLONING-KDX2.xlsm"
        Set DestWB = Application.Workbooks("CLONING-KDX2.xlsm")
    End If
    On Error GoTo 0

    Set WB = ThisWorkbook
    On Error Resume Next
    Set ws = WB.Worksheets("DATABASE")
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "Worksheet 'DATABASE' IS MISSING"
        Exit Sub
    End If
 
    Set DestWS = DestWB.Worksheets("KDX2LIST")
    ColArr = Array("A:A", "D:B", "G:C", "N:D", "M:E", "L:F", "I:G")
    
    Dim DestNextRow As Long
    With DestWS
        DestNextRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        
    End With

    Application.ScreenUpdating = False
    For Each SCol In ColArr
        DCol = Split(SCol, ":")(1)
        SCol = Split(SCol, ":")(0)
        With ws
            Set rng = .Cells(6, SCol)
        End With

        With DestWS
            Set rngDest = .Range(DCol & DestNextRow)
        End With
        rng.Copy
        rngDest.PasteSpecial PASTE:=xlPasteValues
        
        rngDest.Borders.Weight = xlThin
        rngDest.Font.Size = 16
        rngDest.Font.Bold = True
        rngDest.HorizontalAlignment = xlCenter
        rngDest.Cells.Interior.ColorIndex = 6
        rngDest.Cells.RowHeight = 25
    Next SCol
    Application.ScreenUpdating = True
     With Sheets("KDX2LIST")
    If .AutoFilterMode Then .AutoFilterMode = False
    x = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("A3:G" & x).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlYes, DataOption1:=xlSortTextAsNumbers
    ActiveWorkbook.Close savechanges:=True
  End With
  
End Sub

 

[ipbr21054]

Ok
You select a customer in column A then click on the command button to run the code.
The code will copy values from this customer in specific columns & paste them to another worksheet as advised below.

The path to the other worksheet is C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\CLONING-KDX2.xlsm

COPY PASTE
A A
D B
G C
N D
M E
L F
I G

The values are pasted in the next available row then the table "TABLE2" is sorted in column A from A-Z
Headers in Row 2
Row 3 is hidden
Customers details start from row 4
At present last row with values is row 7

Ive added 2 screenshots to show you,partial screenshot on DATABASE worksheet

 

[Joe4]

I think I will need a copy of your destination workbook too in order to test your code.

 

[ipbr21054]

Here we go

DEST WB

 

[Joe4]

I think the issue is it is not capturing the correct row number we need (the row that is selected before we click the button).
So let's add some code to the top of the procedure that captures that at the beginning, i.e.

Private Sub Kdx2_Click()
    
    Dim WB As Workbook, DestWB As Workbook
    Dim ws As Worksheet, DestWS As Worksheet
    Dim rng As Range, rngDest As Range
    Dim ColArr As Variant, SCol As Variant, DCol As Variant
    Dim r As Long
    Dim x

    If ActiveCell.Column > 1 Then Exit Sub
    
'   Grab row number of active row
    r = ActiveCell.Row

    On Error Resume Next
    Set DestWB = Application.Workbooks("CLONING-KDX2.xlsm")

    If DestWB Is Nothing Then
        Workbooks.Open fileName:="C:\Users\Owner\Test\CLONING-KDX2.xlsm"
        Set DestWB = Application.Workbooks("CLONING-KDX2.xlsm")
    End If
    On Error GoTo 0

    Set WB = ThisWorkbook
    On Error Resume Next
    Set ws = WB.Worksheets("DATABASE")
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "Worksheet 'DATABASE' IS MISSING"
        Exit Sub
    End If
 
    Set DestWS = DestWB.Worksheets("KDX2LIST")
    ColArr = Array("A:A", "D:B", "G:C", "N:D", "M:E", "L:F", "I:G")
    
    Dim DestNextRow As Long
    With DestWS
        DestNextRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        
    End With

    Application.ScreenUpdating = False
    For Each SCol In ColArr
        DCol = Split(SCol, ":")(1)
        SCol = Split(SCol, ":")(0)
        With ws
            Set rng = .Cells(r, SCol)
        End With

        With DestWS
            Set rngDest = .Range(DCol & DestNextRow)
        End With
        rng.Copy
        rngDest.PasteSpecial PASTE:=xlPasteValues
        
        rngDest.Borders.Weight = xlThin
        rngDest.Font.Size = 16
        rngDest.Font.Bold = True
        rngDest.HorizontalAlignment = xlCenter
        rngDest.Cells.Interior.ColorIndex = 6
        rngDest.Cells.RowHeight = 25
    Next SCol
    Application.ScreenUpdating = True
     With Sheets("KDX2LIST")
    If .AutoFilterMode Then .AutoFilterMode = False
    x = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("A3:G" & x).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlYes, DataOption1:=xlSortTextAsNumbers
    ActiveWorkbook.Close savechanges:=True
  End With
  
End Sub

That seems to work for me when I test it out on your files.

 

[ipbr21054]

I copied the code above but i get a RTE 91
Object variable or with block variable not set.

When i debug this line is in yellow

Set WB = ThisWorkbook
    On Error Resume Next
    Set ws = WB.Worksheets("DATABASE")
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "Worksheet 'DATABASE' IS MISSING"
        Exit Sub
    End If
 
    Set DestWS = DestWB.Worksheets("KDX2LIST")
    ColArr = Array("A:A", "D:B", "G:C", "N:D", "M:E", "L:F", "I:G")
    
    Dim DestNextRow As Long
    With DestWS
        DestNextRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        
    End With

I have checked the tab name on the destination worksheet & confirm its KDX2LIST

 

[ipbr21054]

I see the path is still called TEST

Let me change it

 

[ipbr21054]

Yes all done.
Changing path from TEST worked.

Many thanks

 

[Joe4]

Sorry, I had to change the path in order to test it out on my side, and forgot to change the path back to what you had originally.

Glad it all works out for you!