Thread: Searching Through Ranges Then Coppying Data From One Sheet to Another

Hi All,

I have been trying to figure out a way of copying some specific data from one excel spreadsheet to another. I have attached the spreadsheet showing the data that i am wanting to copy across.

What i am wanting to achieve is to copy the filename and data about the creation dates and modification dates of a database. The tricky part is how to take the first file revision i.e. 1582 - Spool Installation - 001.db taking the date created and time created and placing this in the new sheet. Then reading down the revision numbers i.e. 1582 - Spool Installation - 008.db and taking the date modified and time modified, putting them into the new sheet.

I am wanting to make this into a macro so that i dont have to keep copying the data across, which is a very laborious task especially when there are around 100 databases to search through.

I have a little knowledge about VB.Net but im not too familiar with VBA for Excel. Any help would be very much appreciated.

Cheers,

Dan


Test Database Sheet.xls

This macro will do it without looping:

Option Explicit

Sub DataExtract()
Dim LR As Long

Application.ScreenUpdating = False
LR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet1").Range("F2:F" & LR).Offset(, 1).FormulaR1C1 = _
        "=IF(RIGHT(RC1,7)=""0001.db"", R[-1]C7+1, R[-1]C7)"

With Sheets("Sheet2")
    On Error Resume Next
    .UsedRange.Cells.Clear
    
    .Range("A1:E1").Value = [{"Filename","Date Created","Time Created","Date Modified","Time Modified"}]
    With .Range("A2:A" & LR)
        .FormulaR1C1 = "=INDEX(Sheet1!C1, MATCH(ROW(R[-1]C1), Sheet1!C7, 0))"
        .Value = .Value
        .SpecialCells(xlConstants, xlErrors).ClearContents
    End With
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    
    .Range("B2:B" & LR).FormulaR1C1 = _
        "=INT(INDEX(Sheet1!C3, MATCH(ROW(R[-1]C1), Sheet1!C7, 0)))"
    .Range("C2:C" & LR).FormulaR1C1 = _
        "=MOD(INDEX(Sheet1!C3, MATCH(ROW(R[-1]C1), Sheet1!C7, 0)),1)"
    .Range("D2:D" & LR).FormulaR1C1 = _
        "=INT(INDEX(Sheet1!C5, MATCH(ROW(R[-1]C1), Sheet1!C7, 0)))"
    .Range("E2:E" & LR).FormulaR1C1 = _
        "=MOD(INDEX(Sheet1!C5, MATCH(ROW(R[-1]C1), Sheet1!C7, 0)),1)"
    
    With .Range("B2:E" & LR)
        .Value = .Value
    End With

    .Range("B:B,D:D").NumberFormat = "m/d/yyyy"
    .Range("C:C,E:E").NumberFormat = "[$-409]h:mm AM/PM;@"
    .Columns.AutoFit
End With

Sheets("Sheet1").Range("G:G").ClearContents
Application.ScreenUpdating = True
End Sub

Try this:

Option Explicit

Sub DataExtract()
Dim LR As Long

Application.ScreenUpdating = False
LR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet1").Range("F2:F" & LR).Offset(, 1).FormulaR1C1 = _
        "=IF(RIGHT(RC1,7)=""0001.db"", R[-1]C7+1, R[-1]C7)"

With Sheets("Sheet2")
    On Error Resume Next
    .UsedRange.Cells.Clear
    
    .Range("A1:E1").Value = [{"Filename","Date Created","Time Created","Date Modified","Time Modified"}]
    With .Range("A2:A" & LR)
        .FormulaR1C1 = "=INDEX(Sheet1!C1, MATCH(ROW(R[-1]C1), Sheet1!C7, 0))"
        .Value = .Value
        .SpecialCells(xlConstants, xlErrors).ClearContents
    End With
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    
    .Range("B2:B" & LR).FormulaR1C1 = _
        "=INT(INDEX(Sheet1!C3, MATCH(ROW(R[-1]C1), Sheet1!C7, 0)))"
    .Range("C2:C" & LR).FormulaR1C1 = _
        "=MOD(INDEX(Sheet1!C3, MATCH(ROW(R[-1]C1), Sheet1!C7, 0)),1)"
    .Range("D2:D" & LR).FormulaR1C1 = _
        "=INT(INDEX(Sheet1!C4, MATCH(ROW(R[-1]C1), Sheet1!C7, 0) + COUNTIF(Sheet1!C7, ROW(R[-1]C[-3])) - 1))"
    .Range("E2:E" & LR).FormulaR1C1 = _
        "=MOD(INDEX(Sheet1!C4, MATCH(ROW(R[-1]C1), Sheet1!C7, 0) + COUNTIF(Sheet1!C7, ROW(R[-1]C[-4])) - 1), 1)"
    
    With .Range("B2:E" & LR)
        .Value = .Value
    End With

    .Range("B:B,D:D").NumberFormat = "m/d/yyyy"
    .Range("C:C,E:E").NumberFormat = "[$-409]h:mm AM/PM;@"
    .Columns.AutoFit
End With

Sheets("Sheet1").Range("G:G").ClearContents
Application.ScreenUpdating = True
End Sub

If that takes care of your need, please click EDIT in your original post, click GO ADVANCED and set the PREFIX box to SOLVED.