Macro update to copy data from sheet 1,2,3 into same sheet

[abraham30]

Hello Everyone!

I want to copy the data from worksheets (with name as Data, search_criteria and Narrative) present in SAS folder into template sheet (1_SetUp_FinalExcel_V10) for fresh arrangement and then regenerate different excel file.

The macro is already available. How to update it I have no idea.

The macro is not able to copy the data from sheet "Narrative" into template sheet "Narrative". Can anybody help me how to write it. ( I asked in diff forum but did not get answer)

Sub xx()
Dim Temp As String
Dim Ligne As Long
Dim l As Integer
Dim c As Integer
Dim StudyTitle As String
Dim FileSave As String
Dim FileOpen1 As String
Dim FileSave1 As String
Dim FileTrame As String
Dim Zone As String


Temp = Dir(ActiveWorkbook.Path & "\SAS\*.xls")
FileSave1 = ActiveWorkbook.Path & "\"
FileOpen1 = FileSave1 & "SAS\"


Application.DisplayAlerts = False
Do While Temp <> ""
    Workbooks.Open FileOpen1 & Temp
        l = 4
        c = 63
        StudyTitle = Cells(1, 1).Value
        FileSave = FileSave1 & Temp & "m"
        FileTrame = FileSave1 & "1_SetUp_FinalExcel_V10.xlsm"
        While IsEmpty(Cells(l, 1)) = False
            l = l + 1
        Wend
    
        Range(Cells(4, 1), Cells(l - 1, c)).Select
        Selection.Copy


    Workbooks("1_SetUp_FinalExcel_V10.xlsm").Sheets("Data").Activate
        l = 6
        c = 2
        Cells(3, 3).Value = StudyTitle
        Cells(l, 2).Activate
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        'Workbooks(Temp).Close


      Cells(l, c).Activate
        While IsEmpty(Cells(l, c)) = False
            l = l + 1
        Wend
     Zone = "=Data!R6C2:R" & l - 1 & "C2"
     ActiveWorkbook.Names("CaseList").RefersToR1C1 = Zone


    'Workbooks(Temp).Sheets("search_criteria").Activate
    Windows(Temp).Activate
    Sheets("search_criteria").Select
    Range("A2:B100").Select
    Selection.Copy
    'Workbooks("1_SetUp_FinalExcel.xlsm").Sheets("search_criteria").Activate
    Workbooks(Temp).Close
    Windows("1_SetUp_FinalExcel_V10.xlsm").Activate
    Sheets("search_criteria").Select
    Range("A4").Select
    ActiveSheet.Paste
    Sheets("Data").Select
    
    
    ActiveWorkbook.SaveAs Filename:=FileSave, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Range("A6").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.ClearContents
    Range("K3:M3").Select
    Selection.ClearContents
    Range("A7").Select
    ActiveWorkbook.SaveAs Filename:=FileTrame, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False


    Temp = Dir
Loop


Range("A1").Select
Application.DisplayAlerts = True


End Sub

The macro is also available in attached sheet "1_SetUp_FinalExcel_V10". when the macro run, it should copy the excel data from the folder "sas" name as ("Exelon (01DEC2013-31DEC2013)") for reference only.

[abraham30]

When I modify the macro, I found the error as run time error 9 (subscript out of range). The modification is done with blank font within macro.

Thanks in advance.

Sub Compilation()
Dim Temp As String
Dim Ligne As Long
Dim l As Integer
Dim c As Integer
Dim StudyTitle As String
Dim FileSave As String
Dim FileOpen1 As String
Dim FileSave1 As String
Dim FileTrame As String
Dim Zone As String


Temp = Dir(ActiveWorkbook.Path & "\SAS\*.xls")
FileSave1 = ActiveWorkbook.Path & "\"
FileOpen1 = FileSave1 & "SAS\"


Application.DisplayAlerts = False
Do While Temp <> ""
    Workbooks.Open FileOpen1 & Temp
        l = 4
        c = 63
        StudyTitle = Cells(1, 1).Value
        FileSave = FileSave1 & Temp & "m"
        FileTrame = FileSave1 & "1_SetUp_FinalExcel_V10.xlsm"
        While IsEmpty(Cells(l, 1)) = False
            l = l + 1
        Wend
    
        Range(Cells(4, 1), Cells(l - 1, c)).Select
        Selection.Copy


    Workbooks("1_SetUp_FinalExcel_V10.xlsm").Sheets("Data").Activate
        l = 6
        c = 2
        Cells(3, 3).Value = StudyTitle
        Cells(l, 2).Activate
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        'Workbooks(Temp).Close


      Cells(l, c).Activate
        While IsEmpty(Cells(l, c)) = False
            l = l + 1
        Wend
     Zone = "=Data!R6C2:R" & l - 1 & "C2"
     ActiveWorkbook.Names("CaseList").RefersToR1C1 = Zone


    'Workbooks(Temp).Sheets("search_criteria").Activate
    Windows(Temp).Activate
    Sheets("search_criteria").Select
    Range("A2:B100").Select
    Selection.Copy
    'Workbooks("1_SetUp_FinalExcel.xlsm").Sheets("search_criteria").Activate
    Workbooks(Temp).Close
    Windows("1_SetUp_FinalExcel_V10.xlsm").Activate
    Sheets("search_criteria").Select
    Range("A4").Select
    ActiveSheet.Paste
    
   Windows(Temp).Activate    Sheets("Narrative").Select
    Range("A1:B200").Select
    Selection.Copy
    Workbooks(Temp).Close
    Windows("1_SetUp_FinalExcel_V10.xlsm").Activate
    Sheets("Narrative").Select
    Range("A1").Select
    ActiveSheet.Paste
    
    Sheets("Data").Select
    
    
    ActiveWorkbook.SaveAs Filename:=FileSave, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Range("A6").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.ClearContents
    Range("K3:M3").Select
    Selection.ClearContents
    Range("A7").Select
    ActiveWorkbook.SaveAs Filename:=FileTrame, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False


    Temp = Dir
Loop


Range("A1").Select
Application.DisplayAlerts = True


End Sub