Solved

Rewrite Copy and Paste Data

Posted on 2010-09-10
18
311 Views
Last Modified: 2012-05-10
Hi Experts,

I would like to request Experts help to rewrite the attached script to copy data from “Source” sheet and paste it in “Sheet2”. This macro will copy and paste data if there is data in column-A (source). Now I need to copy multiple data rows if the data at “start date” (Column_E) to “Sun” (Column_Q).  

I have manually copied the sample data from “Source” sheet at “Sheet2” for Experts to get better view. Hope Experts could help me to create this feature.



Sub ee26208387()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim wsFrom As Worksheet
Dim wsTo As Worksheet
Dim rFrom As Range
Dim rTo As Range
Set wsFrom = Sheets("Source")
Set wsTo = Sheets("Sheet2")
Set rFrom = wsFrom.Range("A2")
Set rTo = wsTo.Range("A7")
While rFrom <> ""
    rFrom.Resize(, 6).Copy rTo
    rFrom.Resize(, 6).Copy
    rTo.PasteSpecial xlPasteValues
    rFrom.Offset(3, 4).Resize(, 13).Copy rTo.Offset(, 6)
    Set rFrom = rFrom.Offset(5)
    Set rTo = rTo.Offset(1)
Wend
Application.EnableEvents = True
Application.ScreenUpdating = True
    
Application.ScreenUpdating = False
Call Headers
Call Checkbox_Data
Application.ScreenUpdating = True

End Sub

Open in new window

CopyPaste-Data.xls
0
Comment
Question by:Theva
  • 8
  • 7
  • 3
18 Comments
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 33652381
my update appears to do what you want.  this just an update of the original work by CyberKiwi in may.

formatting needs work but the Headers routine probably does that.

Sub ee26465017()
   'original by CyberKiwi 24/May/2010 ee26208387
   'update by robberbaron. 11.Sept.2010
   
    'Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim wsFrom As Worksheet
    Dim wsTo As Worksheet
    Dim rFrom As Range
    Dim rTo As Range
    Set wsFrom = Sheets("Source")
    Set wsTo = Sheets("Sheet2")
    Set rFrom = wsFrom.Range("A2")
    Set rTo = wsTo.Range("A7")
    While rFrom <> ""
        rFrom.Resize(, 5).Copy rTo
        rFrom.Resize(, 5).Copy
        rTo.PasteSpecial xlPasteValues
        rFrom.Offset(0, 7).Resize(, 2).Copy rTo.Offset(, 5)
        
        rFrom.Offset(3, 4).Resize(2, 13).Copy rTo.Offset(, 7)
        Set rFrom = rFrom.Offset(6)
        Set rTo = rTo.Offset(3)
    Wend
    Application.EnableEvents = True
    Application.ScreenUpdating = True
        
    'Call Headers
    'Call Checkbox_Data
    Application.ScreenUpdating = True

End Sub

Open in new window

0
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 33652383
attached file with macro.

CopyPaste-Data2.xls
0
 

Author Comment

by:Theva
ID: 33652524
Hi robberbaron,

Thanks a lot for the code. After I run the code it shows error at this line

 "For boxpos = 0 To UBound(ArrBoxes) (Module 2)

Hope you can help me to rectify this error. Attached the workbook for your perusal.
FilteringField-Data.xls
0
Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 33652871
yes.

1/ your formatting on the source sheet is not consistent with your example.
The macro was written to handle only 2 date lines; which is why it fails on the one with 3....  rewrite of the transpose code attached

2/ you are calling the OrderColumns code before the arrBoxes array is initialised.  You need to set the array to correct dimension first.

3/   The TrackOrders attempts to reduce array but doesnt dim it first.  Should it be dim        'reduce array size:
        ReDim Preserve ArrBoxes(UBound(ArrBoxes) - 1)


Sub ee26465017()
   'original by CyberKiwi 24/May/2010 ee26208387
   'update by robberbaron. 11.Sept.2010
   'v3 with multiple date rows
   
    'Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim wsFrom As Worksheet
    Dim wsTo As Worksheet
    Dim rFrom As Range
    Dim rTo As Range
    Set wsFrom = Sheets("Source")
    Set wsTo = Sheets("FilteredField")
    Set rFrom = wsFrom.Range("A2")
    Set rTo = wsTo.Range("A7")
    Do While rFrom <> ""
    
        'find the next from data within 20lines
        For nextoffset = 3 To 20
            If rFrom.Offset(nextoffset, 4) = "" Then Exit For
        Next nextoffset
        'If nextoffset = 21 Then  Exit Do
        nextoffset = nextoffset + 1
        
        rFrom.Resize(, 5).Copy rTo
        rFrom.Resize(, 5).Copy
        rTo.PasteSpecial xlPasteValues
        rFrom.Offset(0, 7).Resize(, 2).Copy rTo.Offset(, 5)
        
        rFrom.Offset(3, 4).Resize(nextoffset - 3, 13).Copy rTo.Offset(, 7)
        Set rFrom = rFrom.Offset(nextoffset)
        Set rTo = rTo.Offset(nextoffset - 3)
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True
        
    Call Headers
    Call Checkbox_Data
    Application.ScreenUpdating = True

End Sub

Open in new window

0
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 33652919
the actual error occurs because the find operation fails looking for < ID>  (note the space) when the column header is <ID>



Sub OrderColumns()
    Dim arange
    Dim boxpos As Integer
    Dim acol As Integer, swapcol As Integer, lastrow As Integer
    Dim swap1 As Variant, swap2 As Variant
    'if some date chosen:
    If Range("a7") <> "" Then
    lastrow = Range("a7").End(xlDown).Row
    
    acol = 1
    Dim ctlName As String, colName As String, rngFind As Range
    
    
        For boxpos = 0 To UBound(ArrBoxes)
            swap1 = Range(Cells(6, acol), Cells(lastrow, acol))
            If ArrBoxes(boxpos) > 0 Then
       '-----------reworked ------------------
                ctlName = "Check Box " & ArrBoxes(boxpos)
                colName = Sheet2.Shapes(ctlName).DrawingObject.Caption
                Set rngFind = Range("a6").EntireRow.Find(What:=colName, LookIn:=xlValues)
              
                If rngFind Is Nothing Then
                    MsgBox "Error finding column <" & colName & ">"
                    Stop    '-------------<<<end rework
                 Else
                    swapcol = rngFind.Column
                    swap2 = Range(Cells(6, swapcol), Cells(lastrow, swapcol))
                    Range(Cells(6, acol), Cells(lastrow, acol)) = swap2
                    Range(Cells(6, swapcol), Cells(lastrow, swapcol)) = swap1
                    acol = acol + 1
                End If

            End If
        Next
    End If
End Sub

Open in new window

0
 

Author Comment

by:Theva
ID: 33653167
Hi robberbaron,

Sorry for the trouble, it shows error at this line again "For boxpos = 0 To UBound(ArrBoxes)"

as "subscript out of range " 

How to fix this?
0
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 33655110
1/ I have updated code to execute. Not sure it does what was intended as havent understood the logic too much.
2/ I had to edit thecaption for ID checkbox to remove the space from front.

made a number of other changes but the OrderColumns routine is still causing a mess up of the headers, then it cant find Thu column.

 I'll leave the review of the ordering logic to you.


FilteringField-Data.xls
0
 
LVL 12

Expert Comment

by:tilsant
ID: 33655991
Hi Theva,

I couldn't rectify the above error. But, as per your initial question, here's is the code.
Run this code whilst on Sheet "Source".


Tils.
Sub Copy_Paste()

    Sheets("Source").Copy after:=Sheets(1)
    
    Columns("E:Q").Copy
    Range("J1").PasteSpecial (xlPasteAll)
    Columns("F:G").Delete Shift:=xlToLeft

    Range("H1:T3").Delete Shift:=xlUp

    Range("A1").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=9, Criteria1:="="
    Range("I2:I65536").SpecialCells(xlCellTypeVisible).EntireRow.Delete
    ActiveSheet.ShowAllData
    
    Selection.AutoFilter Field:=1, Criteria1:="="
    Range("A2:G65536").SpecialCells(xlCellTypeVisible).Select
    With Selection
    .ClearContents
    .Interior.ColorIndex = xlNone
    .Font.Bold = False
    End With
    ActiveSheet.ShowAllData
    
    Selection.AutoFilter Field:=8, Criteria1:="Start Date"
    Range("H2:T65536").SpecialCells(xlCellTypeVisible).Select
    With Selection
    .Interior.ColorIndex = xlNone
    .Font.Bold = False
    .ClearContents
    End With
    
    Selection.AutoFilter
    Range("A1").Select
    
End Sub

Open in new window

0
 

Author Comment

by:Theva
ID: 33657071
Hi Tils,

Thanks for the code. How to paste the data at the designated sheet, let say the sheet's name is "FilteredField". No need to create a new sheet every time run the macro.  
0
 

Author Comment

by:Theva
ID: 33657183
Hi robberbaron,

Thanks for revised code. The "Thu" column error happen because of typo error at the module2. Managed to  fix it.

The main idea of having this data filtering is to align data from "source" for various usage. Some user just need certain data and the check box selection will leverage this request.

Is that possible only showing the selected data based on check box selection?

When I run the macro by "Select All", the data were not aligned properly according to the header. Attached the workbook and I've highlighted the data that I'm referring to. Hope you can help.      
FilteringField-Data-robberbaron.xls
0
 
LVL 12

Assisted Solution

by:tilsant
tilsant earned 150 total points
ID: 33657402
Hi Theva, here is the revised code.



Tils.
Sub Copy_Paste()

    Sheets("Source").Select
    Cells.Copy
    Sheets("FilteredField").Select
    Cells.Select
    ActiveSheet.Paste
    
    Columns("E:Q").Copy
    Range("J1").PasteSpecial (xlPasteAll)
    Columns("F:G").Delete Shift:=xlToLeft

    Range("H1:T3").Delete Shift:=xlUp

    Range("A1").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=9, Criteria1:="="
    Range("I2:I65536").SpecialCells(xlCellTypeVisible).EntireRow.Delete
    ActiveSheet.ShowAllData
    
    Selection.AutoFilter Field:=1, Criteria1:="="
    Range("A2:G65536").SpecialCells(xlCellTypeVisible).Select
    With Selection
    .ClearContents
    .Interior.ColorIndex = xlNone
    .Font.Bold = False
    End With
    ActiveSheet.ShowAllData
    
    Selection.AutoFilter Field:=8, Criteria1:="Start Date"
    Range("H2:T65536").SpecialCells(xlCellTypeVisible).Select
    With Selection
    .Interior.ColorIndex = xlNone
    .Font.Bold = False
    .ClearContents
    End With
    
    Selection.AutoFilter
    Range("A1").Select
    
End Sub

Open in new window

0
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 33661141
1/ I have changed the way the macro displays the data. Now the button only loads the data and each checkbox hides a column of data rather than delete it.  (it just toggles hide on/off) This way the columns can be formatted correctly on load and never need to change.
1.1/ see if this works better. it should be quicker if you have a lot of data also.

2/ I have changed the formatting of the cells you noted. I have made date columns only show date (without time) and the time columns now show 6 digits always to represent 24hr time.  

If the formatting is not how you want, format the cells manually and send back.  Or have a look at the ColumnFormat routine where the formatting is set.

Sub ChangeDisplay()

    Dim abox As Object
    Dim wsFiltered As Worksheet
    Dim colname As String, rngFind As Range
    
    Application.ScreenUpdating = False
    Set wsFiltered = ActiveWorkbook.ActiveSheet
    Dim i As Integer, iCol As Integer
    
    For i = 3 To 21
        
        Set abox = wsFiltered.Shapes("Check Box " & i).DrawingObject
        colname = Trim(abox.Caption)  'strip spaces
        Set rngFind = wsFiltered.Range("a6").EntireRow.Find(What:=colname, lookat:=xlWhole, LookIn:=xlFormulas)
        
        If rngFind Is Nothing Then
            MsgBox "Error finding column <" & colname & ">"
            Stop
         Else
            iCol = rngFind.Column
        End If
         'if checkbox not ticked, set value to true for hidden
        If abox.Value = xlOff Then
            wsFiltered.Columns(iCol).Hidden = True
          Else
            wsFiltered.Columns(iCol).Hidden = False
        End If
        
    Next i
    Application.ScreenUpdating = True
End Sub
Sub TrackOrder()

    ChangeDisplay
    Exit Sub

End Sub

Open in new window

FilteringField-Data-robberbaron2.xls
0
 

Author Comment

by:Theva
ID: 33664796
Hi robberbaron,

Thanks a lot for creatively create this workbook, its really cool :).

I've missed out one check box "Creation Date". How to set the data row for creation date correspond with this new check box? I tried to fix it but failed. Hope you assist me.  
FilteringField-Data-robberbaron3.xls
0
 
LVL 32

Accepted Solution

by:
Robberbaron (robr) earned 350 total points
ID: 33671528
the code in ChangeDisplay iterates between 3 and 21, because that was the range of CheckBox control names.

The new checkbox you have added has a name "Check Box 32".  this makes it hard to iterate over.

So, right click the check box and change the name diplayed in top left corner of sheet to Check Box 22.  Then change the range in ChangeDisplay to be 3 to 22.


I have also deleted a lot (9000+) rows without data from the output sheet, reducing file size back to 70k.

Sub ChangeDisplay()

    Dim abox As Object
    Dim wsFiltered As Worksheet
    Dim colname As String, rngFind As Range
    
    Application.ScreenUpdating = False
    Set wsFiltered = ActiveWorkbook.ActiveSheet
    Dim i As Integer, iCol As Integer
    
    For i = 3 To 22
        
        Set abox = wsFiltered.Shapes("Check Box " & i).DrawingObject
        colname = Trim(abox.Caption)  'strip spaces
        Set rngFind = wsFiltered.Range("a6").EntireRow.Find(What:=colname, lookat:=xlWhole, LookIn:=xlFormulas)
        
        If rngFind Is Nothing Then
            MsgBox "Error finding column <" & colname & ">"
            Stop
         Else
            iCol = rngFind.Column
        End If
         'if checkbox not ticked, set value to true for hidden
        If abox.Value = xlOff Then
            wsFiltered.Columns(iCol).Hidden = True
          Else
            wsFiltered.Columns(iCol).Hidden = False
        End If
        
    Next i
    Application.ScreenUpdating = True
End Sub

Open in new window

FilteringField-Data-robberbaron3.xls
0
 

Author Closing Comment

by:Theva
ID: 33674470
Hi robberbaron,

Thanks a lot for creating a superb workbook for me.

Tils,

Thanks for rewrite the script.

0
 
LVL 12

Expert Comment

by:tilsant
ID: 33674546
Thanks Theva!
Good Night :)


Tils.
0
 

Author Comment

by:Theva
ID: 33674565
Hi Tils,

Good Night too.
0
 

Author Comment

by:Theva
ID: 33842104
Hi tilsant/robberbaron,

Need your expertise for this Q:

http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_26524544.html

Which is related with this threat. Hope you'll consider my request.
0

Featured Post

Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

INDEX and MATCH can be used to great effect to replace HLOOKUP and VLOOKUP as it does not have the limitation of needing the data to be sorted so that the reference value is in the first column or row. It also has the ability to perform a bi-directi…
How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.

821 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question