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

 

[Joe4]

If you want this line of code:

            Set rng = .Cells(6, SCol)

to reference the active row, instead of hard-coded to row 6, you can use:

            Set rng = .Cells(ActiveCell.Row, SCol)

If you only want the code to run when a cell in column A is the ActiveCell when the code is kicked off, add this line near the top of your code:

If ActiveCell.Column > 1 Then Exit Sub

 

[ipbr21054]

Im confused.

At present it transfers the value from A6 row.

I only need to code to run if a cell in column A is selected.
Whatever cell in column A is selected say A100 then the values from that row will be transfered.

So i have used

If ActiveCell.Column > 1 Then Exit Sub

Then removed the reference to

Set rng = .Cells(6, SCol)

But it still did it.

Can you make the edit for me & post the code here that i need to use

 

[Joe4]

Then removed the reference to

Set rng = .Cells(6, SCol)

I never said to REMOVE this row.
I said to replace it with the line I posted in my previous post!

 

[ipbr21054]

That didnt work for mwe & just transfered incorrect values from another customer.

I replaced

Set rng = .Cells(6, SCol)

For this

Set rng = .Cells(ActiveCell.Row, SCol)

 

[Joe4]

Try this:

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
 
    If ActiveCell.Column > 1 Then Exit Sub

    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(ActiveCell.Row, 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

If that does not work, you will need to post a data sample for me to try to run it against.

 

[ipbr21054]

Download Test File from here please.
TEST FILE

 

[Joe4]

Download Test File from here please.
TEST FILE

OK, I will have to check it out later. I am on a work computer right now that forbids us from downloading file from the internet.
So I will need to try later when I am on my home computer.

 

[ipbr21054]

Ok no problem,many thanks

 

[Joe4]

Can you explain, in plain English, exactly what this code is supposed to do?