• 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.

Macro does not copy correctly

A

aleksandra123

New Member
Hi I have developed the below macro. The macro for the first part works perfectly. It fileter by column 6 and then copy and past to another sheet 3 columns. Then it come backs again filter by column 12 but then does not copy column 11 to Z column ( the rest is copied), when it comes back 3 time, filer by column 18 but still doesn copy column 17 to Z column and column 18 is copied as formula not value (wherease in first copy paste and second paste figures as value)
Could someone help me out? Probably loop would be better here but I would like to stay with this macro as I dont have too much time to rebuild everthing.
Code: 
Sub CopyQ1()

Application.ScreenUpdating = False

Dim StartCell As Range

Dim StartCell2 As Range

Dim StartCell3 As Range

Dim StartCell4 As Range

Dim StartCell5 As Range

Dim StartCell6 As Range

Dim StartCell7 As Range

Dim StartCell8 As Range

Dim StartCell9 As Range

Dim LastRow As Long

Dim LastRow2 As Long

Dim LastRow3 As Long

Dim LastRow4 As Long

Dim LastRow5 As Long

Dim LastRow6 As Long

Dim DestLastRow As Long

Dim DestLastRow2 As Long

Dim DestLastRow3 As Long

Dim DestLastRow4 As Long

Dim DestLastRow5 As Long

Dim DestLastRow6 As Long

 

Sheets("xxx").Select

 

'filter the first  by the quater that it is required

      ActiveSheet.Range("$A$8:$AA$60000").AutoFilter Field:=6, Criteria1:="<>0"

 

'settings

Set StartCell = Range("A9")

Set StartCell2 = Range("E9")

Set StartCell3 = Range("F9")

Set sht = Worksheets("xxx")

Set sht2 = Worksheets("zzz")

 

'Find Last Row

  LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row

  LastRow2 = sht.Cells(sht.Rows.Count, StartCell2.Column).End(xlUp).Row

  LastRow3 = sht.Cells(sht.Rows.Count, StartCell3.Column).End(xlUp).Row

 

 

'Copy respective quater for the first and past into zzz file.

    

sht.Range(StartCell, sht.Cells(LastRow, 1)).Copy Destination:=sht2.Range("L4")

sht.Range(StartCell2, sht.Cells(LastRow2, 5)).Copy Destination:=sht2.Range("Z4")

sht.Range(StartCell3, sht.Cells(LastRow3, 6)).Copy Destination:=sht2.Range("V4")

 

'Come back to the xxx

 

Sheets("xxx").Select

 

'Unfilter

ActiveSheet.ShowAllData

 

'Filter the next  by the quater

      ActiveSheet.Range("$A$8:$AA$60000").AutoFilter Field:=12, Criteria1:="<>0"

 

'settings

   Set StartCell4 = Range("A9")

   Set StartCell5 = Range("K9")

   Set StartCell6 = Range("L9")

 

 

 

'Find Last Row and Column

  LastRow4 = sht.Cells(sht.Rows.Count, StartCell4.Column).End(xlUp).Row

  LastRow5 = sht.Cells(sht.Rows.Count, StartCell5.Column).End(xlUp).Row

  LastRow6 = sht.Cells(sht.Rows.Count, StartCell6.Column).End(xlUp).Row

 

  'Find the first empty row in columns in zzz file

  DestLastRow = sht2.Cells(sht2.Rows.Count, "L").End(xlUp).Offset(1).Row

  DestLastRow2 = sht2.Cells(sht2.Rows.Count, "Z").End(xlUp).Offset(1).Row

  DestLastRow3 = sht2.Cells(sht2.Rows.Count, "V").End(xlUp).Offset(1).Row

 

'Copy respective quater for the second  and past into zzz  file.

sht.Range(StartCell4, sht.Cells(LastRow4, 1)).Copy Destination:=sht2.Range("L" & DestLastRow)

sht.Range(StartCell5, sht.Cells(LastRow5, 11)).Copy Destination:=sht2.Range("Z" & DestLastRow2)

sht.Range(StartCell6, sht.Cells(LastRow6, 12)).Copy Destination:=sht2.Range("V" & DestLastRow3)

 

 

'Come back to the xxx

 

Sheets("xxx").Select

 

'Unfilter

ActiveSheet.ShowAllData

 

'Filter the next  by the quater

      ActiveSheet.Range("$A$8:$AA$60000").AutoFilter Field:=18, Criteria1:="<>0"

 

'settings

   Set StartCell7 = Range("A9")

    Set StartCell8 = Range("Q9")

   Set StartCell9 = Range("R9")


 

'Find Last Row and Column

  LastRow7 = sht.Cells(sht.Rows.Count, StartCell7.Column).End(xlUp).Row

  LastRow8 = sht.Cells(sht.Rows.Count, StartCell8.Column).End(xlUp).Row

  LastRow9 = sht.Cells(sht.Rows.Count, StartCell9.Column).End(xlUp).Row

 

  'Find the first empty row in columns in file

  DestLastRow4 = sht2.Cells(sht2.Rows.Count, "L").End(xlUp).Offset(1).Row

  DestLastRow5 = sht2.Cells(sht2.Rows.Count, "Z").End(xlUp).Offset(1).Row

  DestLastRow6 = sht2.Cells(sht2.Rows.Count, "V").End(xlUp).Offset(1).Row

 

 

 

'Copy respective quater for the second and past into zzz  file.

sht.Range(StartCell7, sht.Cells(LastRow7, 1)).Copy Destination:=sht2.Range("L" & DestLastRow4)

sht.Range(StartCell8, sht.Cells(LastRow8, 17)).Copy Destination:=sht2.Range("Z" & DestLastRow5)

sht.Range(StartCell9, sht.Cells(LastRow9, 18)).Copy Destination:=sht2.Range("V" & DestLastRow6)

 

 



 



 

 

'come back to xxx and unfilter the table

Sheets("xxx").Select

ActiveSheet.ShowAllData

 

Application.ScreenUpdating = True

 

End Sub
 
Possibly this will work...
Code: 
Sub Not_Tested()
'!!! Test on a copy of your data !!!

    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lRow As Long
    
    Application.ScreenUpdating = False

    Set ws1 = Worksheets("xxx")
    Set ws2 = Worksheets("zzz")
    
    With ws1.Cells(8, 1).CurrentRegion
        .AutoFilter Field:=6, Criteria1:="<>0"
        lRow = ws2.Cells(Rows.Count, 12).End(xlUp).Offset(1).Row
        .Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lRow, 12)
        .Offset(1).Columns(5).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lRow, 26)
        .Offset(1).Columns(6).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lRow, 22)
        
        .Parent.ShowAllData
        .AutoFilter Field:=12, Criteria1:="<>0"
        lRow = ws2.Cells(Rows.Count, 12).End(xlUp).Offset(1).Row
        .Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lRow, 12)
        .Offset(1).Columns(11).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lRow, 26)
        .Offset(1).Columns(12).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lRow, 22)
        
        .Parent.ShowAllData
        .AutoFilter Field:=18, Criteria1:="<>0"
        lRow = ws2.Cells(Rows.Count, 12).End(xlUp).Offset(1).Row
        .Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lRow, 12)
        .Offset(1).Columns(17).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lRow, 26)
        .Offset(1).Columns(18).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lRow, 22)
        
        .Parent.ShowAllData
    End With
    
    Application.ScreenUpdating = True
End Sub
 
aleksandra123 said:
and column 18 is copied as formula not value
Click to expand...
Generally speaking, to copy values quickly, instead of your:
Code: 
sht.Range(StartCell9, sht.Cells(LastRow9, 18)).Copy Destination:=sht2.Range("V" & DestLastRow6)
which copies everything including formulae, use the likes of:
Code: 
With sht.Range(StartCell9, sht.Cells(LastRow9, 18))
  sht2.Range("V" & DestLastRow6).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
 
You must log in or register to reply here.
Back
Top