Excel macro to copy from two cells from two sheets in one workbook to another

Question

 Sub buildtimetable() Dim FolderName As String Dim Fname As String FolderName = "C:\\New folder\\test" If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator Fname = Dir(FolderName & "*.xls") 'loop through the files Do While Len(Fname) With Workbooks.Open(FolderName & Fname) Dim w As Workbook Dim lastrow As Long lastrow = Range("A300000").End(xlUp).Row ActiveWorkbook.Sheets(2).Select Range("K2").Select Selection.Copy Workbooks("TimeTable.xlsx").Activate Sheets(1).Rows( _ Sheets(1).Range("B" & Rows.Count).End(xlUp).Row + 1 & _ ":" & _ Sheets(1).Range("B" & Rows.Count).End(xlUp).Row + 1 _ ).PasteSpecial _ Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Workbooks(Fname).Activate ActiveWorkbook.Sheets(3).Select Range("K2").Select Selection.Copy Workbooks("TimeTable.xlsx").Activate Sheets(1).Rows( _ Sheets(1).Range("C" & Rows.Count).End(xlUp).Row + 1 & _ ":" & _ Sheets(1).Range("C" & Rows.Count).End(xlUp).Row + 1 _ ).PasteSpecial _ Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False End With ' go to the next file in the folder Fname = Dir Application.DisplayAlerts = False Application.EnableEvents = False ActiveWorkbook.Close Loop End Sub 

I am trying to open a file in my directory and copy the value from cell K2 in sheets 2 and 3 to a new workbook that I have open on the desktop. THis code does not work, I can't seem to figure out where I am going wrong. Mostly having trouble designating which workbook to select/activate.

Answer 1

Code:

Sub buildtimetable()
Dim FolderName As String
Dim Fname As String
Dim w As Worksheet
Dim w1 As Worksheet
Dim w2 As Worksheet

Set w = Workbooks("TimeTable.xlsx").Sheets(1)

FolderName = "C:\New folder\test\"
    Fname = Dir(FolderName & "*.xls")
    'loop through the files
    Do While Len(Fname)
        With Workbooks.Open(FolderName & Fname)
            Set w1 = .Sheets(2)
            Set w2 = .Sheets(3)

            w1.Range("K2").Copy

            w.Range("B" & w.Range("B1").End(xlDown).Row + 1).PasteSpecial _
                                                              Paste:=xlPasteValues, Operation:=xlNone, _
                                                              SkipBlanks:=False, Transpose:=False

            Application.CutCopyMode = False

            w2.Range("K2").Copy

            w.Range("C" & w.Range("C1").End(xlDown).Row + 1).PasteSpecial _
                                                              Paste:=xlPasteValues, Operation:=xlNone, _
                                                              SkipBlanks:=False, Transpose:=False

            Application.CutCopyMode = False

        End With
' go to the next file in the folder
        Fname = Dir

        Application.DisplayAlerts = False

        Application.EnableEvents = False

        .Close
    Loop
End Sub

Answer 2

I am trying this and seems to be working but the copy puts it at the wrong place in the other excel file and it does not copy everything or move down the row properly.

 Sub buildtimetable() Dim FolderName As String Workbooks.Open ("C:\\TimeTable.xlsx") Dim Fname As String FolderName = "C:\\New folder\\test" If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator Fname = Dir(FolderName & "*.xls") 'loop through the files Do While Len(Fname) With Workbooks.Open(FolderName & Fname) Dim lastrow As Long lastrow = Range("B300000").End(xlUp).Row 'Time Workbooks(Fname).Worksheets(2).Range("K2").Copy Workbooks("TimeTable.xlsx").Worksheets(1).Range("B" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats Workbooks(Fname).Worksheets(3).Range("K2").Copy Workbooks("TimeTable.xlsx").Worksheets(1).Range("C" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats 'Max Min value a Workbooks(Fname).Worksheets(1).Range("O2").Copy Workbooks("TimeTable.xlsx").Worksheets(1).Range("D" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats Workbooks(Fname).Worksheets(3).Range("N2").Copy Workbooks("TimeTable.xlsx").Worksheets(1).Range("E" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats 'Max Min value b Workbooks(Fname).Worksheets(2).Range("P2").Copy Workbooks("TimeTable.xlsx").Worksheets(1).Range("F" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats Workbooks(Fname).Worksheets(3).Range("M2").Copy Workbooks("TimeTable.xlsx").Worksheets(1).Range("G" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats End With ' go to the next file in the folder Fname = Dir Application.DisplayAlerts = False Application.EnableEvents = False ActiveWorkbook.Close Loop End Sub