• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

vba copy paste special values not working

B

biffothebear

New Member
I have a slight problem my code if you could help me with it. The full code is below. 2 issues, the first is on the code not pasting the data in to correct row the dump sheet, it is ignoring the last row that contains data for the xl up and pasting the data over the top.

the second issue is that for Sheet FL the data is not pasting in the right rows for columns B & C. The xl up appears not to be looking for the last cell containing data, it is putting the data 29 rows the last cell containing data.

The strange thing is that this is working for columns F & G and I cannot see a difference why.


I have about 20 more sheets I have to do this code for which i can copy the code and change the name of the sheets.

Your valuable help will be very much appreciated.

thanks

>>> use CODE -tags <<<
​
Code: 
Sub Macro2 Macro
'AS SHEET
Dim Lr As Long
With Sheets("AS")
Lr = .Range("I:I").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("I4:I" & Lr).Copy
Sheets("Dump").Range("B5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

With Sheets("AS")
Lr = .Range("J:J").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("J4:J" & Lr).Copy
Sheets("Dump").Range("C5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

With Sheets("AS")
Lr = .Range("M:M").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("M4:M" & Lr).Copy
Sheets("Dump").Range("F5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

With Sheets("AS")
Lr = .Range("N:N").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("N4:N" & Lr).Copy
Sheets("Dump").Range("G5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

'FL SHEET
With Sheets("FL")
Lr = .Range("I:I").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("I4:I" & Lr).Copy
Sheets("Dump").Range("B5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

With Sheets("FL")
Lr = .Range("J:J").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("J4:J" & Lr).Copy
Sheets("Dump").Range("C5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

With Sheets("FL")
Lr = .Range("M:M").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("M4:M" & Lr).Copy
Sheets("Dump").Range("F5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

With Sheets("FL")
Lr = .Range("N:N").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("N4:N" & Lr).Copy
Sheets("Dump").Range("G5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

End Sub

I have found that in the rows that it is skipping the code is putting in a blank space, if that helps!

the results of my code are below: The bottom values (923.60 & 229.95) should line up to the descriptions but don't



the row item numbers for 11 & 12 should be inline with the bold descriptions which are the corresponding items but as you can see there are skipped rows due to my code putting in a blank space in those cells due to the formulas


96.7331/08/2018DOLEAS
106.7331/08/2018DOLEFL
NOAHFL
MR
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
31/08/2018
11923.6031/08/2018
12229.954545531/08/2018
 
Last edited by a moderator:
Biff of the Bear

Firstly, Welcome to the Chandoo.org Forums

Are you able to upload a sample file?
 
Hi Hui,

Thanks, I have uploaded a sample file, I have had to protect the workbook. I hope you are able to view the macro in module 3 that is not working, as you can see in the dump tab the columns B & C are not aligning up to the other columns as they should.

Once it is working, I then have to add module 3 to module 1.

Thanks for your help, this has been tearing my hair out and I don't have much to spare !!! :)
 
Last edited by a moderator:
Hui,

someone helped with me with my code and changed it to the below, but it is still not working. Your help will be appreciated.



Code: 
Sub Macro2()

'AS SHEET

 
 
Dim Lr As Long


  With Sheets("AS")
Lr = .Range("H:H").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("H4:H" & Lr).Copy
Sheets("Dump").Range("A5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With


With Sheets("AS")
Lr = .Range("I:I").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("I4:I" & Lr).Copy
Sheets("Dump").Range("B5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
     
  With Sheets("AS")
Lr = .Range("J:J").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("J4:J" & Lr).Copy
Sheets("Dump").Range("C5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

     
  With Sheets("AS")
Lr = .Range("M:M").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("M4:M" & Lr).Copy
Sheets("Dump").Range("F5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With


  With Sheets("AS")
Lr = .Range("N:N").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("N4:N" & Lr).Copy
Sheets("Dump").Range("G5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

   

   
   
   
   
'FL SHEET

 
  With Sheets("FL")
Lr = .Range("H:H").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("H4:H" & Lr).Copy
Sheets("Dump").Range("A5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
   


With Sheets("FL")
Lr = .Range("I:I").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("I4:I" & Lr).Copy
Sheets("Dump").Range("B5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False



End With
     
  With Sheets("FL")
Lr = .Range("J:J").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("J4:J" & Lr).Copy
Sheets("Dump").Range("C5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

     
  With Sheets("FL")
Lr = .Range("M:M").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("M4:M" & Lr).Copy
Sheets("Dump").Range("F5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With


  With Sheets("FL")
Lr = .Range("N:N").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("N4:N" & Lr).Copy
Sheets("Dump").Range("G5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

Dim myCell As Range, myRng As Range

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

    Set myRng = Sheets("Dump").Cells

    With myRng
        .Replace What:=Chr(160), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13) & Chr(10), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(21), Replacement:=Chr(32), LookAt:=xlPart

        .Replace What:=Chr(8), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(9), Replacement:=Chr(32), LookAt:=xlPart
    End With

    On Error Resume Next
    For Each myCell In Intersect(myRng, _
                                myRng.SpecialCells(xlConstants, xlTextValues))
        myCell.Value = Application.Trim(myCell.Value)
    On Error GoTo 0
    Next myCell

    On Error Resume Next
    Sheets("Dump").Cells.SpecialCells(4).Delete xlUp
    On Error GoTo 0

    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With


   


End Sub
 
Last edited by a moderator:
Not sure What you want to achieve here
May be this?

Code: 
Sub Macro2()

'AS SHEET

   
   
Dim Lr As Long


With Sheets("AS")
Lr = .Range("H:H").Cells.SpecialCells(xlCellTypeConstants).Count + 3
.Range("H4:J" & Lr).Copy
Sheets("Dump").Range("A5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False

Lr = .Range("M:M").Cells.SpecialCells(xlCellTypeConstants).Count + 3
.Range("M4:N" & Lr).Copy
Sheets("Dump").Range("F5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
 
     
     
     
'FL SHEET

 
With Sheets("FL")
Lr = .Range("H:H").Cells.SpecialCells(xlCellTypeConstants).Count + 3
.Range("H4:J" & Lr).Copy
Sheets("Dump").Range("A5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

       
With Sheets("FL")
Lr = .Range("M:M").Cells.SpecialCells(xlCellTypeConstants).Count + 3
.Range("M4:N" & Lr).Copy
Sheets("Dump").Range("F5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With



Dim myCell As Range, myRng As Range

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

    Set myRng = Sheets("Dump").Cells

    With myRng
        .Replace What:=Chr(160), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13) & Chr(10), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(21), Replacement:=Chr(32), LookAt:=xlPart

        .Replace What:=Chr(8), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(9), Replacement:=Chr(32), LookAt:=xlPart
    End With

    On Error Resume Next
    For Each myCell In Intersect(myRng, _
                                myRng.SpecialCells(xlConstants, xlTextValues))
        myCell.Value = Application.Trim(myCell.Value)
    On Error GoTo 0
    Next myCell

    On Error Resume Next
    Sheets("Dump").Cells.SpecialCells(4).Delete xlUp
    On Error GoTo 0

    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With


     

End Sub
 
Hi, unfortunately that did not work, however I have managed to get the cells in column 2 & 3 (B,C) to delete the blank cells with spaces, with the below code, but I have 2 other issues: On the "Dump" tab, columns A, B, C, F & G ignore the last row of data being my header and paste it over the top and same happens with sheet "FL" data, that it pastes over the top over the top of the last row.

So it appears the .End(xlUp) does not work for sheets "AS" and "FL", any idea how to fix this?

Any help appreciated


Code: 
Sub Macro2()

'AS SHEET

  
  
Dim Lr As Long


  With Sheets("AS")
Lr = .Range("H:H").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("H4:H" & Lr).Copy
Sheets("Dump").Range("A5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With


With Sheets("AS")
Lr = .Range("I:I").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("I4:I" & Lr).Copy
Sheets("Dump").Range("B5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
      
  With Sheets("AS")
Lr = .Range("J:J").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("J4:J" & Lr).Copy
Sheets("Dump").Range("C5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

      
  With Sheets("AS")
Lr = .Range("M:M").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("M4:M" & Lr).Copy
Sheets("Dump").Range("F5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With


  With Sheets("AS")
Lr = .Range("N:N").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("N4:N" & Lr).Copy
Sheets("Dump").Range("G5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

    

    
    
    
    
'FL SHEET

  
  With Sheets("FL")
Lr = .Range("H:H").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("H4:H" & Lr).Copy
Sheets("Dump").Range("A5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
    


With Sheets("FL")
Lr = .Range("I:I").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("I4:I" & Lr).Copy
Sheets("Dump").Range("B5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False



End With
      
  With Sheets("FL")
Lr = .Range("J:J").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("J4:J" & Lr).Copy
Sheets("Dump").Range("C5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

      
  With Sheets("FL")
Lr = .Range("M:M").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("M4:M" & Lr).Copy
Sheets("Dump").Range("F5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With


  With Sheets("FL")
Lr = .Range("N:N").Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
.Range("N4:N" & Lr).Copy
Sheets("Dump").Range("G5000").End(xlUp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With


Dim lRow As Integer
Dim intCol As Long
Dim rngCell As Range, fn

Set fn = Application.WorksheetFunction
Application.ScreenUpdating = False
For intCol = 2 To 3
    For lRow = 353 To 2 Step -1
        Set rngCell = Cells(lRow, intCol)
        With rngCell
            .Value = fn.Substitute(rngCell.Value, Chr(160), Chr(32))
            .Value = Trim(rngCell.Value)
        End With
        If Len(rngCell) = 0 Then
            rngCell.Delete shift:=xlUp
        End If
        Set rngCell = Nothing
    Next lRow
Next intCol
Application.ScreenUpdating = True

Sheets("Dump").Select
Range("I11").Select
    Selection.AutoFill Destination:=Range("I11:I206")
  
  
    Range("D11").Select
    Selection.AutoFill Destination:=Range("D11:D206")
   Range("A1").Select
End Sub
 
Last edited by a moderator:
Hi:

Which code are you using? The code you have given above is different to what I had given you.

Note:
Please use code tags when you paste VBA.

Thanks
 
You must log in or register to reply here.
Back
Top