Solved

Rewrite Copy and Paste Data

Posted on 2010-09-10
18
303 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
 
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
What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 

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

What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

Join & Write a Comment

Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

706 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

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now