Macro Saving

S

SueN.Pools

Hello all. So this is what I'm trying to do. I have an excel
spreadsheet that I export from a program, creating a text file. This
file I have to open in excel, and then copy and paste sections into a
worksheet that contains three sheets. In this second spreadsheet,
there is a macro that runs certain checks and then makes the file
into
an XML.
What I am attempting to do is create a macro that will look in a
folder on my desktop that contains around 10 of these exported text
files, run it through the copy and paste macro that i have created,
and then run the macro in the second spreadsheet. I would then like
to save both the second spreadsheet I've pasted on and the XML file.
So what I have done so far is listed below. I managed to make a
window pop up to select the files i want to run through the macro.
What I would actually prefer to do is just look in a folder and run
ALL files in there that are excel spreadsheets. I then run the copy
paste macro and select the XML macro to run and then things just sort
of stop. As i run the macro, it stops to prompt me to name the XML
file. What I would love to do (and have attempted) is to name the
file automatically a cell from the Second Workbook. I cant figure out
how to get around this propmt and name it automatically.

I would really appreciate if someone would look at what I've done.
Im
really new at this and im sure theres alot of cleaning up to do. I
may
have made this way more complicated then it needs to be. Thanks in
advance for your help!

Sub CopyPaste2()
Application.ScreenUpdating = False
Dim wbCurrent As Workbook
files_to_open = _
Application.GetOpenFilename("Excel files (*.xls), _*.xls", , , ,
True)
If Not IsArray(files_to_open) Then
MsgBox "Nothing selected"
Exit Sub
Else
For i = LBound(files_to_open) To UBound(files_to_open)
Set wbCurrent = Workbooks.Open(files_to_open(i))
Application.StatusBar = "Processing " & files_to_open(i)
FinalCopy wbCurrent

FinalCopy(myWB As Workbook)
Range("B18").Select
Application.CutCopyMode = False
Selection.Cut Destination:=Range("C18")
Range("B28").Select
Selection.Cut Destination:=Range("C28")
Range("D18").Select
ActiveCell.FormulaR1C1 = "=CLEAN(RC[-1])"
Range("D28").Select
ActiveCell.FormulaR1C1 = "=CLEAN(RC[-1])"
Range("D18").Select
Selection.Copy
Range("B18").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("D28").Select
Application.CutCopyMode = False
Selection.Copy
Range("B28").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Rows("1:1").Select
Selection.Delete Shift:=xlUp
ChDir "C:\Documents and Settings\Owner\Desktop"
Workbooks.Open Filename:= _
"C:\Documents and Settings\Owner\Desktop\Second
Worksheet.xls"

ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Sheets("Demographic Info").Select
ActiveWindow.ScrollRow = 12
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
myWB.Activate
Range("B1:B5").Select
Selection.Copy
Windows("Second Worksheet.xls").Activate
Range("B2").Select
ActiveSheet.Paste
myWB.Activate
Range("B8:B19").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Second Worksheet.xls").Activate
Range("B10").Select
ActiveSheet.Paste
myWB.Activate
ActiveWindow.SmallScroll Down:=18
Range("B23:B30").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Second Worksheet").Activate
Range("B25").Select
ActiveSheet.Paste
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 12
Sheets("Sheet 2").Select
myWB.Activate
Range("B34:B44").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Second Worksheet.xls").Activate
Range("B3").Select
ActiveSheet.Paste
myWB.Activate
ActiveWindow.SmallScroll Down:=12
Range("B49:H49").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Second Worksheet.xls").Activate
Range("A18").Select
ActiveSheet.Paste
Sheets("Sheet 3").Select
myWB.Activate
Rows("51:170").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A51"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
Range("A51:O86").Select
Selection.Copy
Windows("Second Worksheet.xls").Activate
Range("A5").Select
ActiveSheet.Paste

myWB.Activate
Range("B49").Select
Selection.Copy

Windows("Second Worksheet.xls").Activate
ActiveWindow.SmallScroll ToRight:=4
Sheets("Sheet 3").Select
ActiveWindow.SmallScroll ToRight:=3
Application.Run "MakeXML"

NewFilename = Left(files_to_open(i), Len(files_to_open(i)) - 4) _
& " - Testing - please delete.xls"
wbCurrent.SaveAs NewFilename
wbCurrent.Close
Next i
End If
Set wbCurrent = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox UBound(files_to_open) - LBound(files_to_open) + _
1 & " files processed (hopefully)."
End Function

Const fPath As String = "C:\Documents and Settings\Desktop\"
Dim fName As String
Dim myFileName As String

myFileName = "EXCEL" & Sheets("Sheet 2").Range("A18") & ".xls"
fName = fPath & myFileName

ActiveSheet.SaveAs Filename = fName
MsgBox "File Saved to " & fName

End Function

THANKS!
 
J

Jim Cone

http://www.cpearson.com/excel/newposte.htm



<[email protected]>
wrote in message
Hello all. So this is what I'm trying to do. I have an excel
spreadsheet that I export from a program, creating a text file. This
file I have to open in excel, and then copy and paste sections into a
worksheet that contains three sheets. In this second spreadsheet,
there is a macro that runs certain checks and then makes the file
into
an XML.
What I am attempting to do is create a macro that will look in a
folder on my desktop that contains around 10 of these exported text
files, run it through the copy and paste macro that i have created,
and then run the macro in the second spreadsheet. I would then like
to save both the second spreadsheet I've pasted on and the XML file.
So what I have done so far is listed below. I managed to make a
window pop up to select the files i want to run through the macro.
What I would actually prefer to do is just look in a folder and run
ALL files in there that are excel spreadsheets. I then run the copy
paste macro and select the XML macro to run and then things just sort
of stop. As i run the macro, it stops to prompt me to name the XML
file. What I would love to do (and have attempted) is to name the
file automatically a cell from the Second Workbook. I cant figure out
how to get around this propmt and name it automatically.

I would really appreciate if someone would look at what I've done.
Im
really new at this and im sure theres alot of cleaning up to do. I
may
have made this way more complicated then it needs to be. Thanks in
advance for your help!

Sub CopyPaste2()
Application.ScreenUpdating = False
Dim wbCurrent As Workbook
files_to_open = _
Application.GetOpenFilename("Excel files (*.xls), _*.xls", , , ,
True)
If Not IsArray(files_to_open) Then
MsgBox "Nothing selected"
Exit Sub
Else
For i = LBound(files_to_open) To UBound(files_to_open)
Set wbCurrent = Workbooks.Open(files_to_open(i))
Application.StatusBar = "Processing " & files_to_open(i)
FinalCopy wbCurrent

FinalCopy(myWB As Workbook)
Range("B18").Select
Application.CutCopyMode = False
Selection.Cut Destination:=Range("C18")
Range("B28").Select
Selection.Cut Destination:=Range("C28")
Range("D18").Select
ActiveCell.FormulaR1C1 = "=CLEAN(RC[-1])"
Range("D28").Select
ActiveCell.FormulaR1C1 = "=CLEAN(RC[-1])"
Range("D18").Select
Selection.Copy
Range("B18").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("D28").Select
Application.CutCopyMode = False
Selection.Copy
Range("B28").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Rows("1:1").Select
Selection.Delete Shift:=xlUp
ChDir "C:\Documents and Settings\Owner\Desktop"
Workbooks.Open Filename:= _
"C:\Documents and Settings\Owner\Desktop\Second
Worksheet.xls"

ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Sheets("Demographic Info").Select
ActiveWindow.ScrollRow = 12
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
myWB.Activate
Range("B1:B5").Select
Selection.Copy
Windows("Second Worksheet.xls").Activate
Range("B2").Select
ActiveSheet.Paste
myWB.Activate
Range("B8:B19").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Second Worksheet.xls").Activate
Range("B10").Select
ActiveSheet.Paste
myWB.Activate
ActiveWindow.SmallScroll Down:=18
Range("B23:B30").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Second Worksheet").Activate
Range("B25").Select
ActiveSheet.Paste
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 12
Sheets("Sheet 2").Select
myWB.Activate
Range("B34:B44").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Second Worksheet.xls").Activate
Range("B3").Select
ActiveSheet.Paste
myWB.Activate
ActiveWindow.SmallScroll Down:=12
Range("B49:H49").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Second Worksheet.xls").Activate
Range("A18").Select
ActiveSheet.Paste
Sheets("Sheet 3").Select
myWB.Activate
Rows("51:170").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A51"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
Range("A51:O86").Select
Selection.Copy
Windows("Second Worksheet.xls").Activate
Range("A5").Select
ActiveSheet.Paste

myWB.Activate
Range("B49").Select
Selection.Copy

Windows("Second Worksheet.xls").Activate
ActiveWindow.SmallScroll ToRight:=4
Sheets("Sheet 3").Select
ActiveWindow.SmallScroll ToRight:=3
Application.Run "MakeXML"

NewFilename = Left(files_to_open(i), Len(files_to_open(i)) - 4) _
& " - Testing - please delete.xls"
wbCurrent.SaveAs NewFilename
wbCurrent.Close
Next i
End If
Set wbCurrent = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox UBound(files_to_open) - LBound(files_to_open) + _
1 & " files processed (hopefully)."
End Function

Const fPath As String = "C:\Documents and Settings\Desktop\"
Dim fName As String
Dim myFileName As String

myFileName = "EXCEL" & Sheets("Sheet 2").Range("A18") & ".xls"
fName = fPath & myFileName

ActiveSheet.SaveAs Filename = fName
MsgBox "File Saved to " & fName

End Function

THANKS!
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Help! 1
variable number of rows. 2
fixing a run-time error'9': Subscript out of range 0
Run Macros 11
Need Help with VBA code for an Excel Model Macro 5
Excel Macro delete certail column's 1
Macro that deletes and pastes filterd rows and then some 2
Retaining data on clipboard after close without prompt. 1

Top