troubleshooting Question

Modify Copy and Paste script

Avatar of Billa7
Billa7 asked on
Microsoft Excel
13 Comments1 Solution203 ViewsLast Modified:
I need Expert help to fix this problem. The attached script is used to copy data from .xls workbook into Data sheet. The script only copy data which is start at 0600 and above; omit time before 0600. However, this rules only applicable for the start of the day, not after midnight. I hope Expert rectify this by allowing copy of the time after midnight. The removing of before 0600 only for start of the day. I have attached the workbook together with sample data files for Experts perusal.
Sub Copy_Paste()
    Dim wb As Workbook
    Dim fName As String
    Dim strFilePath, lcTargetCell
    Dim strPath As String
    Dim intSrcRows As Integer
    Dim intTgtRows As Integer
    Dim rng As Range
    Dim r As Range
    Dim rDelete As Range
    Dim objFileDLG As Office.FileDialog
    
    
    Application.ScreenUpdating = False
    
    strPath = "D:\\"
    
    
    
    'intTgtRows = 6
    intTgtRows = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row + 1
     
    Set objFileDLG = Application.FileDialog(msoFileDialogFilePicker)
 
    Do While True
        strFilePath = ""
        With objFileDLG
            .Filters.Add "Excel Files", "*.xls", 1
            .FilterIndex = 1
            .InitialFileName = strPath
            .AllowMultiSelect = False
            .Title = "Select The Workbook to copy From "
            If .Show() <> 0 Then
                strFilePath = .SelectedItems(1)
            End If
        End With
        
        If Trim(strFilePath) = "" Then Exit Do
        
        Set wb = Workbooks.Open(strFilePath)
                
        wb.Activate
        intSrcRows = wb.Worksheets(1).Cells(Cells.Rows.Count, "A").End(xlUp).Row
        wb.Worksheets(1).Range("A2:D" & intSrcRows).Copy
        
        lcTargetCell = "A" & intTgtRows
         
        ThisWorkbook.Worksheets(2).Activate
        Range(lcTargetCell).Select
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
                   xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        wb.Close
        Set wb = Nothing
        
        Set rng = Selection.Resize(Selection.Rows.Count, 1)
        For Each r In rng
            If r.Offset(0, 1).Value < "0600" Then
                Debug.Print r.Offset(0, 1).Value, "0600"
                If rDelete Is Nothing Then
                    Set rDelete = r
                Else
                    Set rDelete = Union(rDelete, r)
                End If
            End If
        Next r
        
        rDelete.EntireRow.Delete
        
        intTgtRows = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row + 1
        

        Set rDelete = Nothing
    Loop
    
    Application.ScreenUpdating = True
End Sub
CopyData.xls
Sample2.xls
Sample3.xls
Sample4.xls
ASKER CERTIFIED SOLUTION
Rob Brockett

Our community of experts have been thoroughly vetted for their expertise and industry experience.

Join our community to see this answer!
Unlock 1 Answer and 13 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 13 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros