Copy values only without specific column formats VBA

[sofas]

Welcome. I have this code to filter worksheet 1 and copy certain columns to the target columns on worksheet 2. It works very well for me. The only drawback is that it copies formats. What I want is
Editing it, for example, makes it possible to copy values only without formatting, whether fonts or formulas.

Sub test()
Dim WS As Worksheet: Set WS = Sheets("Sheet1")
Dim r  As Worksheet: Set r = Worksheets("Sheet2")

    Sup = MsgBox("Copy data", _
    vbCritical + vbYesNo, "Confirmation")
        
        If Sup = vbYes Then

Application.ScreenUpdating = False
With WS
 If .AutoFilterMode Then .AutoFilterMode = False

With WS.Range("A1:J1")
    .AutoFilter 3, "Paris"

lr = WS.Columns("A:G").Find(What:="*", _
     SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    
    Set Rng = WS.Range("A" & lr & ":G" & lr).SpecialCells(xlCellTypeVisible)
    If WorksheetFunction.Subtotal(3, WS.Columns(3)) > 1 Then
        r.Range("A2:G" & r.Rows.Count).ClearContents

With Rng

    rngA = split("A,B,C,D,E,F,G", ",")
    
    rngB = split("B,A,E,C,D,F,G", ",")

For i = LBound(rngA) To UBound(rngA)
        WS.Range(rngA(i) & "2:" & rngA(i) & lr).Copy r.Range(rngB(i) & "2")
    Next i
 End With
 
End If
  .AutoFilter
End With
End With

 End If
Application.ScreenUpdating = True
End Sub

 

[Akuini]

Untested:
Try replacing this part:

For i = LBound(rngA) To UBound(rngA)
        WS.Range(rngA(i) & "2:" & rngA(i) & lr).Copy r.Range(rngB(i) & "2")
    Next i
 End With

with this:

For i = LBound(rngA) To UBound(rngA)
    With WS.Range(rngA(i) & "2:" & rngA(i) & lr)
        r.Range(rngB(i) & "2").Resize(.Rows.Count, Columns.Count).Value = .Value
    End With
Next i

 

[sofas]

Untested:
Try replacing this part:

For i = LBound(rngA) To UBound(rngA)
        WS.Range(rngA(i) & "2:" & rngA(i) & lr).Copy r.Range(rngB(i) & "2")
    Next i
 End With

with this:

For i = LBound(rngA) To UBound(rngA)
    With WS.Range(rngA(i) & "2:" & rngA(i) & lr)
        r.Range(rngB(i) & "2").Resize(.Rows.Count, Columns.Count).Value = .Value
    End With
Next i

Unfortunately it doesn't work

 

[Alex Blakenburg]

Unless I am mistaken you are only copying 1 column at a time so get rid of the column resize in @Akuini's suggestion:

For i = LBound(rngA) To UBound(rngA)
    With WS.Range(rngA(i) & "2:" & rngA(i) & lr)
        r.Range(rngB(i) & "2").Resize(.Rows.Count).Value = .Value
    End With
Next i

 

[Akuini]

it doesn't work

Can you describe it in more detail?

 

[sofas]

Unless I am mistaken you are only copying 1 column at a time so get rid of the column resize in @Akuini's suggestion:

For i = LBound(rngA) To UBound(rngA)
    With WS.Range(rngA(i) & "2:" & rngA(i) & lr)
        r.Range(rngB(i) & "2").Resize(.Rows.Count).Value = .Value
    End With
Next i

Unfortunately, things didn't work out that way.

 

[Alex Blakenburg]

Neither "it doesn't work" or "things didn't work out that way." give us any idea of what is not working ie what is it doing and how is it different from what it should be doing, hence Akuini's request for more detail ?

 

[sofas]

Neither "it doesn't work" or "things didn't work out that way." give us any idea of what is not working ie what is it doing and how is it different from what it should be doing, hence Akuini's request for more detail ?

I'm really sorry, I probably couldn't have explained the idea more clearly. Here is the file with my code. This works fine. What I want is to copy the values without formatting. thank you In advance.

TestCopy.xlsm

Shared with Dropbox

www.dropbox.com

Internxt Drive – Private & Secure Cloud Storage

Stand for privacy, switch to Internxt. Internxt's open-source cloud storage services, Internxt Drive, Photos, Send, and more, protect your right to privacy.

drive.internxt.com

 

[Alex Blakenburg]

I have made some small changes, see how you go with this.
If you want to preformat your output sheet then change the .Clear back to .ClearContents.
If you have dates and numbers try xlPasteValuesAndNumberFormats instead of xlPasteValues and see if you like what it does.
PS: You had with statements inside of with statements most of which didn't seem to do anything.

Sub test()
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    Dim r  As Worksheet: Set r = Worksheets("Sheet2")

    Sup = MsgBox("Copy data", _
    vbCritical + vbYesNo, "Confirmation")
        
    If Sup = vbYes Then

        Application.ScreenUpdating = False
        With WS
            If .AutoFilterMode Then .AutoFilterMode = False
        End With
    
            With WS.Range("A1:G1")
                .AutoFilter 3, "Paris"
    
                lr = WS.Columns("A:G").Find(What:="*", _
                        SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        
                Set Rng = WS.Range("A" & lr & ":G" & lr).SpecialCells(xlCellTypeVisible)
                If WorksheetFunction.Subtotal(3, WS.Columns(3)) > 1 Then
                    r.Range("A2:G" & r.Rows.Count).Clear                            ' Use ClearContents if you are pre-formatting the output sheet
                
                    rngA = Split("A,B,C,D,E,F,G", ",")
                    rngB = Split("B,A,E,C,D,F,G", ",")
                    
                    For i = LBound(rngA) To UBound(rngA)
                        WS.Range(rngA(i) & "2:" & rngA(i) & lr).Copy
                            r.Range(rngB(i) & "2").PasteSpecial Paste:=xlPasteValues ' Alternatively use xlPasteValuesAndNumberFormats
                    Next i
                End If
                .AutoFilter
            End With
            Application.CutCopyMode = False
            Application.ScreenUpdating = True
        End If

End Sub

 

[sofas]

I have made some small changes, see how you go with this.
If you want to preformat your output sheet then change the .Clear back to .ClearContents.
If you have dates and numbers try xlPasteValuesAndNumberFormats instead of xlPasteValues and see if you like what it does.
PS: You had with statements inside of with statements most of which didn't seem to do anything.

Sub test()
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    Dim r  As Worksheet: Set r = Worksheets("Sheet2")

    Sup = MsgBox("Copy data", _
    vbCritical + vbYesNo, "Confirmation")
       
    If Sup = vbYes Then

        Application.ScreenUpdating = False
        With WS
            If .AutoFilterMode Then .AutoFilterMode = False
        End With
   
            With WS.Range("A1:G1")
                .AutoFilter 3, "Paris"
   
                lr = WS.Columns("A:G").Find(What:="*", _
                        SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
       
                Set Rng = WS.Range("A" & lr & ":G" & lr).SpecialCells(xlCellTypeVisible)
                If WorksheetFunction.Subtotal(3, WS.Columns(3)) > 1 Then
                    r.Range("A2:G" & r.Rows.Count).Clear                            ' Use ClearContents if you are pre-formatting the output sheet
               
                    rngA = Split("A,B,C,D,E,F,G", ",")
                    rngB = Split("B,A,E,C,D,F,G", ",")
                   
                    For i = LBound(rngA) To UBound(rngA)
                        WS.Range(rngA(i) & "2:" & rngA(i) & lr).Copy
                            r.Range(rngB(i) & "2").PasteSpecial Paste:=xlPasteValues ' Alternatively use xlPasteValuesAndNumberFormats
                    Next i
                End If
                .AutoFilter
            End With
            Application.CutCopyMode = False
            Application.ScreenUpdating = True
        End If

End Sub

Very cool thank you @Alex Blakenburg. Always find us the right solution