macro for special copy / paste

M

MSchädler

Board Regular
Joined
Apr 27, 2017
Messages
95
Hello and I need some help with defining a macro to do the following.

My excel file has 2 register; "export" and "archive".
At the end of each month I want to copy each line entry from register "export" that has a date stamp within that month and paste it into the register "archive" below the last entry. The challenge is that the copy/paste is a matrix (see below).
At the end of the macro I want to delete the copied data from the register "export" that has the date stamp within that month.


The actual month is defined with the data in cell "A30" in register "export".
There is an active-x button in register "export" that when "clicked" will run the macro.
This macro should do the following: each line in register "export" that has the date in column "E" that is within the month (eg. 01.11.-30.11.2017), it should copy each cell and paste each cell in register "archive* below the last entry. Each cell of the copied line will be pasted in a different column in the register "archive". The copy/paste matrix should be as follow:

  • copy from register "export" column "A" and paste in register "archive" below last entry in column "A"
  • copy from register "export" column "B" and paste in register "archive" below last entry in column "I"
  • copy from register "export" column "C" and paste in register "archive" below last entry in column "H"
  • copy from register "export" column "D" and paste in register "archive" below last entry in column "D"
  • copy from register "export" column "E" and paste in register "archive" below last entry in column "B"
  • copy from register "export" column "F" and paste in register "archive" below last entry in column "J"
  • copy from register "export" column "G" and paste in register "archive" below last entry in column "G"
  • copy from register "export" column "H" and paste in register "archive" below last entry in column "E"
  • copy from register "export" column "I" and paste in register "archive" below last entry in column "C"
  • copy from register "export" column "J" and paste in register "archive" below last entry in column "F"

Set up in register "export"
[TABLE="width: 600"]
<tbody>[TR]
[TD][TABLE="width: 600"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]State[/TD]
[TD]Typ[/TD]
[TD]Case1[/TD]
[TD]Case2[/TD]
[TD]Date[/TD]
[TD]Entry1[/TD]
[TD]Entry2[/TD]
[TD]Entry3[/TD]
[TD]Type[/TD]
[TD]Net[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]test1[/TD]
[TD]test2[/TD]
[TD]test3[/TD]
[TD]test4[/TD]
[TD="align: right"]30.11.2017[/TD]
[TD]test5[/TD]
[TD]test6[/TD]
[TD]test7[/TD]
[TD]test8[/TD]
[TD]test9[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Set up in register "archive"
[TABLE="width: 557"]
<tbody>[TR]
[TD][TABLE="width: 557"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[/TR]
[TR]
[TD]State[/TD]
[TD]Date[/TD]
[TD]Entry1[/TD]
[TD]Case2[/TD]
[TD]Type[/TD]
[TD]Net[/TD]
[TD]Entry2[/TD]
[TD]Case1[/TD]
[TD]Typ[/TD]
[TD]Entry3[/TD]
[/TR]
[TR]
[TD]test1[/TD]
[TD="align: right"]30.11.2017[/TD]
[TD]test8[/TD]
[TD]test4[/TD]
[TD]test7[/TD]
[TD]test9[/TD]
[TD]test6[/TD]
[TD]test3[/TD]
[TD]test2[/TD]
[TD]test5[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD="align: right"][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Thank you for your help with this macro. Kind regards, Marc
 
Last edited:
Sort by date Sort by votes
Re: Help needed for vba-code (macro) for special copy / paste

So are you saying the first time the script may fill down to row 20 and the next time you want to start filling in at row 21?

Do you want headers copied over every time?
 
Upvote 0

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Re: Help needed for vba-code (macro) for special copy / paste

My Aswer Is This said:
So are you saying the first time the script may fill down to row 20 and the next time you want to start filling in at row 21?

Do you want headers copied over every time?
Click to expand...

Yes, I would like to continue adding below the last entry. Your comment is correct. Also I dont want to take the header each time.
Looking forward to your suggestions.

Regards, Marc
 
Upvote 0
Re: Help needed for vba-code (macro) for special copy / paste

Try this:
Code: 
Sub Filter_Me()
Application.ScreenUpdating = False
'Modified 12-1-17 11:10 AM EST
    Dim LR As Long
    LR = Sheets("archive").Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    With ActiveSheet.Range(Cells(1, "E"), Cells(Cells(Rows.Count, "E").End(xlUp).Row, "E"))
        
    'This Month
    .AutoFilter Field:=1, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
    'Next Month
    '.AutoFilter Field:=1, Criteria1:=xlFilterNextMonth, Operator:=xlFilterDynamic
    'LastMonth
    '.AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic
    .Offset(0, -4).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("archive").Cells(LR, 1)
    .Offset(0, -3).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("archive").Cells(LR, 9)
    .Offset(0, -2).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("archive").Cells(LR, 8)
    .Offset(0, -1).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("archive").Cells(LR, 4)
    .Offset(0, 0).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("archive").Cells(LR, 2)
    .Offset(0, 1).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("archive").Cells(LR, 10)
    .Offset(0, 2).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("archive").Cells(LR, 7)
    .Offset(0, 3).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("archive").Cells(LR, 5)
    .Offset(0, 4).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("archive").Cells(LR, 3)
    .Offset(0, 5).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("archive").Cells(LR, 6)
    .AutoFilter
    End With
    
    Sheets("export").Rows(1).Copy Sheets("archive").Rows(1)
    
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Re: Help needed for vba-code (macro) for special copy / paste

Corrected the code because of some non blank cells.

Code: 
[COLOR=#0000cd]Sub Schaltfläche1_Klicken()
[/COLOR][COLOR=#d3d3d3]'[/COLOR][COLOR=#0000cd]
[/COLOR][COLOR=#d3d3d3]'based on code by Fluff - MrExcel MVP
'by lhartono[/COLOR][COLOR=#0000cd]
[/COLOR][COLOR=#d3d3d3]'Function UpdateArchive()[/COLOR][COLOR=#0000cd]

    Dim WorkRng1 As Range, Rng1 As Range
    Dim StartTime       As Double
    Dim MinutesElapsed  As String
    Dim intMonth        As Integer
    Dim rowLast         As Long
    Dim arrExport       As Variant
    Dim hashSet         As Object
    Dim strDelete       As String
    Dim strExport       As String
    Dim strArchive      As String
    
    StartTime = Timer
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    strExport = "Aus UBSExport"
    strArchive = "Archiv Alt"
    
    intMonth = Month(Sheets(strExport).Range("A30").Value)
    
    Set WorkRng1 = Sheets(strExport).Range("E2:E" & (Sheets(strExport).Range("E" & Rows.Count).End(xlUp).Row))
    Set hashSet = CreateObject("Scripting.Dictionary")

    For Each Rng1 In WorkRng1
        If (Not IsEmpty(Rng1.Value)) And (Len(Trim(Rng1.Value)) > 0) And IsDate(Rng1.Value) Then
            If Month(Rng1.Value) = intMonth Then
                hashSet.Add Rng1.Value & "|" & Rng1.Address, Rng1.Address
            End If
        End If
    Next Rng1
    
    If hashSet.Count > 0 Then
        For Each Rng1 In WorkRng1
            If hashSet.Exists(Rng1.Value & "|" & Rng1.Address) Then
                arrExport = Sheets(strExport).Range("A" & Rng1.Row & ":" & "J" & Rng1.Row)
                rowLast = Sheets(strArchive).Range("D" & Rows.Count).End(xlUp).Row + 1
                With Sheets(strArchive)
                    .Range("A" & rowLast).Value2 = arrExport(1, 1)  'A
                    .Range("B" & rowLast).Value2 = arrExport(1, 5)  'E
                    .Range("C" & rowLast).Value2 = arrExport(1, 9)  'I
                    .Range("D" & rowLast).Value2 = arrExport(1, 4)  'D
                    .Range("E" & rowLast).Value2 = arrExport(1, 8)  'H
                    .Range("F" & rowLast).Value2 = arrExport(1, 10) 'J
                    .Range("G" & rowLast).Value2 = arrExport(1, 7)  'G
                    .Range("H" & rowLast).Value2 = arrExport(1, 3)  'C
                    .Range("I" & rowLast).Value2 = arrExport(1, 2)  'B
                    .Range("J" & rowLast).Value2 = arrExport(1, 6)  'F
                End With
                Erase arrExport
            End If
        Next Rng1
        
        For Each Rng1 In WorkRng1
            If hashSet.Exists(Rng1.Value & "|" & Rng1.Address) Then
                strDelete = strDelete & (Rng1.Row & ":" & Rng1.Row) & ","
            End If
        Next
        
        If (Right(strDelete, 1)) = "," Then
            strDelete = Left(strDelete, Len(strDelete) - 1)
        End If
        
       Sheets(strExport).Range(strDelete).Select
        If (MsgBox("  Delete selected rows?  ", vbQuestion + vbOKCancel, "Confirmation")) = vbYes Then
            Sheets(strExport).Range(strDelete).Delete Shift:=xlUp
        End If
        Sheets(strExport).Range("A2").Select
    End If
    
    hashSet.RemoveAll
    Set hashSet = Nothing
    Set Rng1 = Nothing
    Set WorkRng1 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    Debug.Print "The Code Took " & MinutesElapsed & " (hh:mm:ss) To Run"

End Sub[/COLOR]
 
Upvote 0
Re: Help needed for vba-code (macro) for special copy / paste

lhartono said:
Corrected the code because of some non blank cells.

Code: 
[COLOR=#0000cd]Sub Schaltfläche1_Klicken()
[/COLOR][COLOR=#d3d3d3]'[/COLOR][COLOR=#0000cd]
[/COLOR][COLOR=#d3d3d3]'based on code by Fluff - MrExcel MVP
'by lhartono[/COLOR][COLOR=#0000cd]
[/COLOR][COLOR=#d3d3d3]'Function UpdateArchive()[/COLOR][COLOR=#0000cd]

    Dim WorkRng1 As Range, Rng1 As Range
    Dim StartTime       As Double
    Dim MinutesElapsed  As String
    Dim intMonth        As Integer
    Dim rowLast         As Long
    Dim arrExport       As Variant
    Dim hashSet         As Object
    Dim strDelete       As String
    Dim strExport       As String
    Dim strArchive      As String
    
    StartTime = Timer
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    strExport = "Aus UBSExport"
    strArchive = "Archiv Alt"
    
    intMonth = Month(Sheets(strExport).Range("A30").Value)
    
    Set WorkRng1 = Sheets(strExport).Range("E2:E" & (Sheets(strExport).Range("E" & Rows.Count).End(xlUp).Row))
    Set hashSet = CreateObject("Scripting.Dictionary")

    For Each Rng1 In WorkRng1
        If (Not IsEmpty(Rng1.Value)) And (Len(Trim(Rng1.Value)) > 0) And IsDate(Rng1.Value) Then
            If Month(Rng1.Value) = intMonth Then
                hashSet.Add Rng1.Value & "|" & Rng1.Address, Rng1.Address
            End If
        End If
    Next Rng1
    
    If hashSet.Count > 0 Then
        For Each Rng1 In WorkRng1
            If hashSet.Exists(Rng1.Value & "|" & Rng1.Address) Then
                arrExport = Sheets(strExport).Range("A" & Rng1.Row & ":" & "J" & Rng1.Row)
                rowLast = Sheets(strArchive).Range("D" & Rows.Count).End(xlUp).Row + 1
                With Sheets(strArchive)
                    .Range("A" & rowLast).Value2 = arrExport(1, 1)  'A
                    .Range("B" & rowLast).Value2 = arrExport(1, 5)  'E
                    .Range("C" & rowLast).Value2 = arrExport(1, 9)  'I
                    .Range("D" & rowLast).Value2 = arrExport(1, 4)  'D
                    .Range("E" & rowLast).Value2 = arrExport(1, 8)  'H
                    .Range("F" & rowLast).Value2 = arrExport(1, 10) 'J
                    .Range("G" & rowLast).Value2 = arrExport(1, 7)  'G
                    .Range("H" & rowLast).Value2 = arrExport(1, 3)  'C
                    .Range("I" & rowLast).Value2 = arrExport(1, 2)  'B
                    .Range("J" & rowLast).Value2 = arrExport(1, 6)  'F
                End With
                Erase arrExport
            End If
        Next Rng1
        
        For Each Rng1 In WorkRng1
            If hashSet.Exists(Rng1.Value & "|" & Rng1.Address) Then
                strDelete = strDelete & (Rng1.Row & ":" & Rng1.Row) & ","
            End If
        Next
        
        If (Right(strDelete, 1)) = "," Then
            strDelete = Left(strDelete, Len(strDelete) - 1)
        End If
        
       Sheets(strExport).Range(strDelete).Select
        If (MsgBox("  Delete selected rows?  ", vbQuestion + vbOKCancel, "Confirmation")) = vbYes Then
            Sheets(strExport).Range(strDelete).Delete Shift:=xlUp
        End If
        Sheets(strExport).Range("A2").Select
    End If
    
    hashSet.RemoveAll
    Set hashSet = Nothing
    Set Rng1 = Nothing
    Set WorkRng1 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    Debug.Print "The Code Took " & MinutesElapsed & " (hh:mm:ss) To Run"

End Sub[/COLOR]
Click to expand...

Hello Ihartono
Many thanks for your help with this script. I've run this new script version and it runs pretty good.
The only thing that is not working yet is that the script does not delete the copied date of the 6 rows.
in my test file, we copy 6 rows
in sheet "Aus UBSExport"​
, paste them in the sheet "Archiv Alt" but it does not delete the initial 6 rows in sheet "Aus UBSExport".
I'll try to find why and maybe you have some more suggestions.

Thanks for your help. Marc
 
Upvote 0
Re: Help needed for vba-code (macro) for special copy / paste

So I'm assuming you did not like my new script since you did not comment back and now it seems your more interested in the other posters script.

So I will move on and try and help someone else.
I was going to have my script clear the original sheet after we get this part working correctly
I need not attempt to help any more no need two of us here working on this same project.

There are hundreds of other questions that have never been answered I should try to help out with.
 
Upvote 0
Re: Help needed for vba-code (macro) for special copy / paste

My Aswer Is This said:
So I'm assuming you did not like my new script since you did not comment back and now it seems your more interested in the other posters script.

So I will move on and try and help someone else.
I was going to have my script clear the original sheet after we get this part working correctly
I need not attempt to help any more no need two of us here working on this same project.

There are hundreds of other questions that have never been answered I should try to help out with.
Click to expand...


Hi there, I'm ok with you helping others. I did like your script. But it is not finished and that script does not continuously add the copied data to an existing sheet (archive) and it does not delete the initial copied data.
Many thanksfor your help !
 
Last edited:
Upvote 0
Re: Help needed for vba-code (macro) for special copy / paste

The last script does add to the sheet every time you use it.
I test these scripts.
 
Upvote 0
Re: Help needed for vba-code (macro) for special copy / paste

Hello there, I'm confused. I believe that there are two board members giving me answers and scripts to my initial request, one was a Board member with no name and the other was I Ihartono.
The two scripts worked differently.
Now maybe I'm wrong with my assumption and it was always you who replied.
The script from Ihartono worked fine except the last one did not "delete" the copied cells in "export".
If that is the case I'm sending you my excuses.
 
Upvote 0
Re: Help needed for vba-code (macro) for special copy / paste

Not sure what you mean when you say one has no name.

I see Ihartono here and then me : My Answer Is This.

So I guess if you need more help on one of the scripts you like you should say

Ihartono I want to use your script but still need more help on this:

Or say:

My Answer Is This I want to use your script and need more help on this:
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Macro copy text above
Replies
1
Views
134
Kaper
Kaper
B
  • Question Question
VBA exports worksheet from XLSM to XLXS matching all source properties doesn't keep print area
Replies
0
Views
85
brentcole
B
R
  • Solved
Macro to copy variable length table and paste numerous times in the same sheet
Replies
9
Views
242
rynardc
R
R
  • Question Question
Copy paste special change in macro
Replies
5
Views
401
Rhodie72
Rhodie72
O
  • Solved
copy paste macro
Replies
1
Views
528
orsm6
O

Forum statistics

Threads
1,223,648
Messages
6,173,566
Members
452,520
Latest member
Pingaware

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top