dub
11-29-2010, 11:40 AM
Hello, I am kinda new to VBA and I am sure this code is very messy. However, I am trying to paste a selection of data from one workbook into another workbook. The code I have written allows the user to open the wb where the data is and a template wb for pasting the data into. I run into problems when trying to paste into the desired wb. I want to paste the data into the wb named "Results" which should be the the template the user opened, resaved as what ever they choose, but named "Results" so that the code knows what wb I am refering to. Does this make sence?
Here is the code so far, the copy/paste selection are all at the bottom, most are commented out b/c once I get one to work I can get the rest. Thanks.
Sub AsBuiltCreate()
'
' AsBuiltCreator Program
' Copies desired rows/columns and puts them in new work book in proper format
'
' By Eric Schaub, LMCO intern
' Program Created: 11/16/2010
'
Dim MySelection As Range
Dim Resutls As Variant
Dim AddrString As String, AddrLength As Integer, FirstStrip As String
Dim Charnum As Integer, ColonCharNum As Integer, FirstNum As Integer
Dim SecondNum As Integer
Dim Results As Workbook
Dim asbuilt As Workbook
m = MsgBox("Double left mouse click on the template file.", , "Select Template") 'prompts to locate template file
Template = Application.GetOpenFilename("Excel Files (*.xlsx;*.xls;*.dat;*.XLS), *.xlsx;*.xls;*.dat;*.XLS", , "Open the Template") 'opens browser window
Line0:
If Template = "False" Then 'gives error message if no file is selected and gives the option to retry or stop
E = MsgBox("Must select a Template File.", vbExclamation + vbRetryCancel, "Error")
If E = vbRetry Then
Template = Application.GetOpenFilename("Excel Files (*.xlsx;*.xls;*.dat;*.XLS), *.xlsx;*.xls;*.dat;*.XLS", , "Open the Template") 'opens browser window
GoTo Line0
ElseIf E = vbCancel Then
Exit Sub
End If
End If
m = MsgBox("Double left mouse click the As-Built File.", , "Select AD FILE") 'prompts to locate AB file
AB = Application.GetOpenFilename("Excel Files (*.xls;*.dat;*.XLS;*.xlsx), *.xls;*.dat;*.XLS;*.xlsx", , "Open the AB FILE") 'opens browser window
Line1:
If AB = "False" Then 'gives error message if no file is selected and gives the option to retry or stop
E = MsgBox("Must enter an AB file.", vbExclamation + vbRetryCancel, "Error")
If E = vbRetry Then
AB = Application.GetOpenFilename("Excel Files (*.xls;*.dat;*.XLS;*.xlsx), *.xls;*.dat;*.XLS;*.xlsx", , "Open the AD FILE")
GoTo Line1
ElseIf E = vbCancel Then
Exit Sub
End If
End If
Application.ScreenUpdating = False
'Open AB
Workbooks.Open Filename:=AB
asbuilt = ActiveWorkbook.Name
'Open template
Workbooks.Open Filename:=Template
Results = ActiveWorkbook.Name
Results = Application.GetSaveAsFilename("C:\Temp\File.xls", _
"Workbook (*.xls), *.xls", , "Save As:")
Line2:
If Results = False Then
E = MsgBox("Must specify name and location.", vbExclamation + vbRetryCancel, "Error")
If E = vbRetry Then
Results = Application.GetSaveAsFilename("C:\Temp\File.xls", _
"Workbook (*.xls), *.xls", , "Save As:")
GoTo Line2
ElseIf E = vbCancel Then
Exit Sub
End If
End If
DataSelection:
'Open AB
Workbooks.Open Filename:=AB
asbuilt = ActiveWorkbook.Name
Set asbuilt = ActiveWorkbook
Application.ScreenUpdating = True
Set MySelection = Application.InputBox(Prompt:="Select a range of cells", Type:=8)
MySelection.Select
'If MySelection = "" Then 'gives error message if no rows are selected and gives the option to retry or stop
'E = MsgBox("Must select at least one row", vbExclamation + vbRetryCancel, "Error")
'If E = vbRetry Then
'GoTo DataSelection
' ElseIf E = vbCancel Then
'Exit Sub
' End If
' End If
AddrString = Selection.Address
AddrLength = Len(AddrString)
FirstStrip = Right(AddrString, AddrLength - 1)
For Charnum = 1 To AddrLength - 1
If Mid(FirstStrip, Charnum, 1) = ":" Then
ColonCharNum = Charnum
Exit For
End If
Next Charnum
start_row = Left(FirstStrip, ColonCharNum - 1)
end_row = Right(FirstStrip, AddrLength - 2 - ColonCharNum)
int_row = 3
paste_row = int_row
'Data Manipulation
Range("H" & start_row & ":H" & end_row).Select
Selection.Copy
Sheet2.Activate
Range("K" & paste_row).Select
Sheet2.Paste
'Windows(asbuilt).Activate
'Range("J" & start_row & ":J" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("L" & paste_row).Select
'Sheet1.Paste
'Set asbuilt = ActiveWorkbook
'Sheet1.Activate
'Range("N" & start_row & ":N" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("A" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("O" & start_row & ":O" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("C" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("P" & start_row & ":P" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("H" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("T" & start_row & ":T" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("N" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("X" & start_row & ":X" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("D" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("AA" & start_row & ":AA" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("I" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("AB" & start_row & ":AB" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("J" & paste_row).Select
'Sheet2.Paste
Done = MsgBox(Prompt:="Do you wish to select more data", _
Buttons:=vbYesNo, Title:="Finished?")
If Done = vbYes Then
GoTo DataSelection
ElseIf Done = vbNo Then
Exit Sub
End If
paste_row = paste_row + (end_row - start_row)
End Sub
thanks
Here is the code so far, the copy/paste selection are all at the bottom, most are commented out b/c once I get one to work I can get the rest. Thanks.
Sub AsBuiltCreate()
'
' AsBuiltCreator Program
' Copies desired rows/columns and puts them in new work book in proper format
'
' By Eric Schaub, LMCO intern
' Program Created: 11/16/2010
'
Dim MySelection As Range
Dim Resutls As Variant
Dim AddrString As String, AddrLength As Integer, FirstStrip As String
Dim Charnum As Integer, ColonCharNum As Integer, FirstNum As Integer
Dim SecondNum As Integer
Dim Results As Workbook
Dim asbuilt As Workbook
m = MsgBox("Double left mouse click on the template file.", , "Select Template") 'prompts to locate template file
Template = Application.GetOpenFilename("Excel Files (*.xlsx;*.xls;*.dat;*.XLS), *.xlsx;*.xls;*.dat;*.XLS", , "Open the Template") 'opens browser window
Line0:
If Template = "False" Then 'gives error message if no file is selected and gives the option to retry or stop
E = MsgBox("Must select a Template File.", vbExclamation + vbRetryCancel, "Error")
If E = vbRetry Then
Template = Application.GetOpenFilename("Excel Files (*.xlsx;*.xls;*.dat;*.XLS), *.xlsx;*.xls;*.dat;*.XLS", , "Open the Template") 'opens browser window
GoTo Line0
ElseIf E = vbCancel Then
Exit Sub
End If
End If
m = MsgBox("Double left mouse click the As-Built File.", , "Select AD FILE") 'prompts to locate AB file
AB = Application.GetOpenFilename("Excel Files (*.xls;*.dat;*.XLS;*.xlsx), *.xls;*.dat;*.XLS;*.xlsx", , "Open the AB FILE") 'opens browser window
Line1:
If AB = "False" Then 'gives error message if no file is selected and gives the option to retry or stop
E = MsgBox("Must enter an AB file.", vbExclamation + vbRetryCancel, "Error")
If E = vbRetry Then
AB = Application.GetOpenFilename("Excel Files (*.xls;*.dat;*.XLS;*.xlsx), *.xls;*.dat;*.XLS;*.xlsx", , "Open the AD FILE")
GoTo Line1
ElseIf E = vbCancel Then
Exit Sub
End If
End If
Application.ScreenUpdating = False
'Open AB
Workbooks.Open Filename:=AB
asbuilt = ActiveWorkbook.Name
'Open template
Workbooks.Open Filename:=Template
Results = ActiveWorkbook.Name
Results = Application.GetSaveAsFilename("C:\Temp\File.xls", _
"Workbook (*.xls), *.xls", , "Save As:")
Line2:
If Results = False Then
E = MsgBox("Must specify name and location.", vbExclamation + vbRetryCancel, "Error")
If E = vbRetry Then
Results = Application.GetSaveAsFilename("C:\Temp\File.xls", _
"Workbook (*.xls), *.xls", , "Save As:")
GoTo Line2
ElseIf E = vbCancel Then
Exit Sub
End If
End If
DataSelection:
'Open AB
Workbooks.Open Filename:=AB
asbuilt = ActiveWorkbook.Name
Set asbuilt = ActiveWorkbook
Application.ScreenUpdating = True
Set MySelection = Application.InputBox(Prompt:="Select a range of cells", Type:=8)
MySelection.Select
'If MySelection = "" Then 'gives error message if no rows are selected and gives the option to retry or stop
'E = MsgBox("Must select at least one row", vbExclamation + vbRetryCancel, "Error")
'If E = vbRetry Then
'GoTo DataSelection
' ElseIf E = vbCancel Then
'Exit Sub
' End If
' End If
AddrString = Selection.Address
AddrLength = Len(AddrString)
FirstStrip = Right(AddrString, AddrLength - 1)
For Charnum = 1 To AddrLength - 1
If Mid(FirstStrip, Charnum, 1) = ":" Then
ColonCharNum = Charnum
Exit For
End If
Next Charnum
start_row = Left(FirstStrip, ColonCharNum - 1)
end_row = Right(FirstStrip, AddrLength - 2 - ColonCharNum)
int_row = 3
paste_row = int_row
'Data Manipulation
Range("H" & start_row & ":H" & end_row).Select
Selection.Copy
Sheet2.Activate
Range("K" & paste_row).Select
Sheet2.Paste
'Windows(asbuilt).Activate
'Range("J" & start_row & ":J" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("L" & paste_row).Select
'Sheet1.Paste
'Set asbuilt = ActiveWorkbook
'Sheet1.Activate
'Range("N" & start_row & ":N" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("A" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("O" & start_row & ":O" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("C" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("P" & start_row & ":P" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("H" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("T" & start_row & ":T" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("N" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("X" & start_row & ":X" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("D" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("AA" & start_row & ":AA" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("I" & paste_row).Select
'Sheet2.Paste
'Windows(asbuilt).Activate
'Range("AB" & start_row & ":AB" & end_row).Select
'Application.CutCopyMode = False
'Selection.Copy
'Windows(Results).Activate
'Range("J" & paste_row).Select
'Sheet2.Paste
Done = MsgBox(Prompt:="Do you wish to select more data", _
Buttons:=vbYesNo, Title:="Finished?")
If Done = vbYes Then
GoTo DataSelection
ElseIf Done = vbNo Then
Exit Sub
End If
paste_row = paste_row + (end_row - start_row)
End Sub
thanks