发帖
雷达卡
将 Tramo/Seats 季节调整作为 excel 中的一个函数使用，不知为什么没法传附件，就直接把源代码贴上来吧（VBA），自己将它另存为 excel 的 xla 加载宏使用，很方便的。
主要是使用 TS 的自动处理过程，可以选择输出季调后序列，或季节因素，或两者，可以选择是否包含预测。
调用方法：
ts(x As Range, Optional start_year As Integer = 2000, Optional start_period As Integer = 1, Optional freq As Integer = 12, Optional out_serie As Integer = 1, Optional forecast As Boolean = False)
实在是太缺钱了，象征性的收点，见谅。使用中若有问题，请在此回复。
Private Declare Function WaitForSingleObject Lib "kernel32" _ (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Function CloseHandle Lib "kernel32" _ (ByVal hObject As Long) As Long Private Declare Function OpenProcess Lib "kernel32" _ (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) As Long Private Const INFINITE = -1& Private Const SYNCHRONIZE = &H100000
Option Explicit
Function ts(x As Range, Optional start_year As Integer = 2000, Optional start_period As Integer = 1, Optional freq As Integer = 12, Optional out_serie As Integer = 1, Optional forecast As Boolean = False) 'A simple excel interface to TRAMO/SEATS ' ' 'Use the full automatic procedure, RSA=3, but force the log transformation ' ' 'Copyright Jun 2005 ' 'by Xia Chun
Dim iTask As Long, ret As Long, pHandle As Long Dim fs, fd Dim cell As Range Dim CurrentDrive As String, CurrentPath As String Dim Line As String Dim ss() As String Dim l As Integer, i As Integer Dim rows As Integer, cols As Integer Dim ts_out() As Double Const PathToTramo As String = "c:\tramo" Const PathToOutFile As String = "c:\seats\output\table-s.out" Set fs = CreateObject("Scripting.FileSystemObject") ' Generate the input file Set fd = fs.CreateTextFile(PathToTramo & "\serie", True) l = x.Count fd.writeline ("tmpserie") fd.writeline (l & " " & start_year & " " & start_period & " " & freq) For Each cell In x If IsNumeric(cell) And cell > 0 Then fd.writeline (cell) Else fd.writeline ("-99999") Next cell fd.writeline ("$INPUT RSA=3,LAM=0$") fd.Close Set fd = Nothing CurrentPath = CurDir() CurrentDrive = Left(CurrentPath, 2) ChDrive (Left(PathToTramo, 2)) ChDir (PathToTramo) 'Call ts.exe to do seasonal adjustment iTask = Shell(PathToTramo & "\ts.exe", vbHide) pHandle = OpenProcess(SYNCHRONIZE, False, iTask) ret = WaitForSingleObject(pHandle, INFINITE) ret = CloseHandle(pHandle) ChDrive (CurrentDrive) ChDir (CurrentPath) 'Read the output file Set fd = fs.opentextfile(PathToOutFile, 1) fd.skipline fd.skipline If forecast Then rows = l + 2 * freq Else rows = l If out_serie > 2 Then cols = 2 Else cols = 1 ReDim ts_out(1 To rows, 1 To cols) i = 1 Do While Not fd.atendofstream And i <= rows Line = fd.readline() ss = Split(slim(Line)) Select Case out_serie Case 1 ts_out(i, 1) = ss(3) Case 2 ts_out(i, 1) = ss(4) Case 3 ts_out(i, 1) = ss(3) ts_out(i, 2) = ss(4) Case Else End Select i = i + 1 Loop fd.Close Set fd = Nothing Set fs = Nothing ts = ts_out End Function
Function slim(s As String, Optional d As String = " ") As String 'slip the consecutive delimiter d in string s and trim the left and right delimiters ' 'Copyright June, 2005 by Xia Chun
Dim l As Integer Dim i As Integer
slim = "" l = Len(s) i = 1
'Trim the left delimiters first Do While i <= l And Mid(s, i, 1) = d i = i + 1 Loop
Do While i <= l ' if a delimiter found, skip it until next non-delimiter character, or we simply link the ' character to output and move the pointer next If Mid(s, i, 1) = d Then Do i = i + 1 Loop Until i > l Or Mid(s, i, 1) <> d If i <= l Then slim = slim & d ' if we don't reach the end of string, add a single delimiter to output Else slim = slim & Mid(s, i, 1) i = i + 1 End If Loop
End Function
[此贴子已经被作者于2005-6-21 19:26:21编辑过]
京公网安备 11010802022788号
