Copy Data From Another Workbook

[umaido]

Hi,
I am having a problem. I have a workbook named "BOOK1" with three sheets named Sheet1, Sheet2, Sheet3. Each sheet has only two columns: Name and DOB. Now, I would like to copy from 3 sheets of BOOK1 those Names having DOB from 1/1/2000 to 1/1/2011. to a new work book named BOOK2. Can anyone help me to write this macro? (I intend to write this as code of sheet1 in BOOK2. So, BOOK2 is supposed already opened) Thanks in advance.

 

[pbornemeier]

Welcome to the Board!

Sub GetDataFromBook1()
    Dim lX As Long
    Dim lY As Long
    Dim bFound As Boolean
    Dim dteStart As Date
    Dim dteEnd As Date
    Dim lLastInputRow As Long
    Dim lNextWriteRow As Long
    Dim sSourceWorkbook As String
 
    sSourceWorkbook = "Book1.xls"
    dteStart = #1/1/2000#
    dteEnd = #1/1/2011#
    lNextWriteRow = 2
 
    For lX = 1 To Workbooks.Count
        If Workbooks(lX).Name = sSourceWorkbook Then
            bFound = True
            Exit For
        End If
    Next
 
    If bFound Then
        Worksheets("Sheet1").Cells.Clear
        Worksheets("Sheet1").Range("A1:B1").Value = Array("Name", "DOB")
 
        For lX = 1 To 3
            lNextWriteRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
            With Workbooks(sSourceWorkbook).Worksheets("Sheet" & lX)
                .AutoFilterMode = False
                .Range("A1").CurrentRegion.AutoFilter
                .Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:= _
                    ">=" & dteStart, Operator:=xlAnd, Criteria2:="<=" & dteEnd
                .Range(.Range("A2"), .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy
            End With
            With ThisWorkbook.Worksheets("Sheet1").Cells(lNextWriteRow, 1)
                .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                    SkipBlanks:=False, Transpose:=False
            End With
            With Workbooks(sSourceWorkbook).Worksheets("Sheet" & lX)
                .AutoFilterMode = False
            End With
        Next
 
        With ThisWorkbook.Worksheets("Sheet1")
            .Columns("B:B").EntireColumn.AutoFit
            .Columns("A:A").EntireColumn.AutoFit
        End With
    Else
        MsgBox "Open " & sSourceWorkbook & " and run this procedure again."
    End If
 
End Sub

 

[umaido]

Thank you very much for your quick reply! Now, I would like to have one more question about the problem that's similar to the last one. I would like the date is changable.

Here is the brief information about what I did and got errors:

* 2 BOOKs :
- BOOK1: 4 Sheets: DATES contains just two dates, users can change any time. And Sheet1, Sheet2, Sheet3 (these 3 sheets contain NAME,
DOB)
- BOOK2: Sheet DATA which is used to copy data from the three sheets in BOOK1

- I did the code below and it worked OK if I used DATEVALUE function and specific dates(ex. 1/1/2000 to 1/1/2011) in IF Statement.
- I got error messages when I called CELL value in the Sheet DATES(for example A1: 1/1/2000, A2: 1/1/2011)

* So, my code is seems to have a problem at two lines of IF Statement when I called the dates from Sheet DATES in BOOK1.

I would like to do so because I want let the users change dates when they need and just run the macro.

Again, I would be very appreciate any helps!

Here is my code:
---------------------
Sub Report()
Dim WkSht As Worksheet
Dim wb As Workbook
Dim r As Integer
Set wb = Workbooks.Open("BOOK1.xlsx")
For Each WkSht In wb.Worksheets
If WkSht.Name <> "DATES" Then
For r = 1 To 100
IF WkSht.Range("B",&r) >= Sheets("DATES").Range("A1").Value _
And WkSht.Range("B,&r) <= Sheets("DATES").Range("A2").Value Then
WkSht.Rows(r & ":" & r).Copy
Windows("Summary.xlsx").Activate
Sheets("DATA2").Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Sheets("DATA2").Range("B" & Sheets("DATA2").Range("A65536").End(xlUp).Row).Value = WkSht.Name
End If
Next r
End If
Next WkSht
End Sub
----------------------

 

[pbornemeier]

Try
WkSht.Range("B" & r)
no comma