Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 336
  • Last Modified:

Rewrite Copy and Paste Data

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
Theva
Asked:
Theva
  • 8
  • 7
  • 3
2 Solutions
 
Robberbaron (robr)Commented:
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
 
Robberbaron (robr)Commented:
attached file with macro.

CopyPaste-Data2.xls
0
 
ThevaAuthor Commented:
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
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
Robberbaron (robr)Commented:
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
 
Robberbaron (robr)Commented:
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
 
ThevaAuthor Commented:
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
 
Robberbaron (robr)Commented:
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
 
tilsantCommented:
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
 
ThevaAuthor Commented:
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
 
ThevaAuthor Commented:
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
 
tilsantCommented:
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
 
Robberbaron (robr)Commented:
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
 
ThevaAuthor Commented:
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
 
Robberbaron (robr)Commented:
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
 
ThevaAuthor Commented:
Hi robberbaron,

Thanks a lot for creating a superb workbook for me.

Tils,

Thanks for rewrite the script.

0
 
tilsantCommented:
Thanks Theva!
Good Night :)


Tils.
0
 
ThevaAuthor Commented:
Hi Tils,

Good Night too.
0
 
ThevaAuthor Commented:
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 does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

  • 8
  • 7
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now