PDA

View Full Version : Macro update to copy data from sheet 1,2,3 into same sheet



abraham30
07-29-2014, 11:06 AM
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
07-29-2014, 09:19 PM
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