Copy large List and move to another worksheet

[fredrerik84]

Hi guys :=)

I have a ton of data stored in Row 27 to about 300 Cell A-AF (but more and more data is inserted)
At the end of every month I would like to move all this date over to a summarize sheet then I will delete all this data in the original sheet and start fresh.

I need it to copy all data from sheet1 - sheet2 (starting on row 27 to lastrow) This I will do the 1st every month
so the first month sheet 2 will be empty but the 2nd month It should not overwrite the data in sheet2 but continue
I also have Icons in coloum F,L,O they should not be copied as this uses to much resources

I guess this is not so difficult , but im very unsure how to start writing the code for the button ., Any help would be great

 

[fredrerik84]

This is what I have so far but have a syntax error in the paste code :/

Sub Summary()


Dim lr As Long
Dim i As Long
Dim j As Long
Dim lrh As Long
    
    'Find the last non-blank cell in column A(1)
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    lrh = lr - 300
    For i = 300 To lr - 1
      For j = 1 To lrh
        Range(Cells(i, "D"), Cells(i, "D")).Copy
        Worksheets("BetHistory").Cells(j, "A").PasteSpecial.Values
      Next j
    Next i
    
End Sub

 

[vcoolio]

Hello Fredrerik84,

Based on your opening post, try the following code instead:-

Sub CopyData()

Dim lrow As Long

Application.ScreenUpdating = False

lrow = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
If lrow > 26 Then
Sheet1.Range("A27:AF" & lrow).Copy
Sheet2.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
Sheet1.Range("A27:AF" & lrow).ClearContents
End If

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

It will copy/paste (values only) all the data from Sheet1, row 27 on over to Sheet2.

You may need to change the sheet references to suit yourself.

I hope that this helps.

Cheerio,
vcoolio.

P.S.: The code will also clear the data in Sheet1 from row27 on.

 

[fredrerik84]

Hi thanks for your reply , Im not sure how one closes these threads but I manged to make this list yesterday by here is my code :

Dim i As Long
Dim j As Long
Dim lrh As Long
Dim Rng As Range
Dim sRow As Long
Dim eRow As Long
Dim Blr As Long
Dim ws As Worksheet
Dim sh As Shape
Dim mbResult As Integer
mbResult = MsgBox("These changes cannot be undone. Are you sure you would like to proceed?", _
 vbYesNo)
'sRow = selectedRng.Row
'eRow = sRow + selectedRng.Rows.Count - 1
Blr = Worksheets("BetHistory").Cells(Rows.Count, 2).End(xlUp).Row + 1
 
Select Case mbResult
 Case vbYes
'Find the last non-blank cell in column A(28)
    lr = Cells(Rows.Count, 28).End(xlUp).Row
    If lr < 27 Then
       MsgBox "Error, - Can not archive open bets!"
       Exit Sub
    Else
       i = 27
    End If
    Set Rng = Range(Cells(i, "C"), Cells(lr, "P"))
     
        Range(Cells(i, "D"), Cells(lr - 1, "AA")).Copy
        Worksheets("BetHistory").Range("B" & Blr).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Range(Cells(i, "AE"), Cells(lr - 1, "AE")).Copy
        Worksheets("BetHistory").Range("L" & Blr).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False


    
    
    For Each sh In ActiveSheet.Shapes
        On Error Resume Next
        If Intersect(Rng, sh.TopLeftCell) Is Nothing Then
        Else
           sh.Delete
        End If
    Next sh
    Rng.EntireRow.Delete
    Cells(27, "A").Value = "1"
    Cells(27, "B").Value = "0"
    MsgBox "Row 27 to Row " & lr & " have been stored in sheet: BetHistory", vbExclamation
    ActiveWindow.ScrollRow = 1
    Call expand
    Call expand
 Case vbNo
   End Select
 Exit Sub
End Sub