- 帖子
- 2035
- 主題
- 24
- 精華
- 0
- 積分
- 2031
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office2010
- 閱讀權限
- 100
- 性別
- 男
- 註冊時間
- 2012-3-22
- 最後登錄
- 2024-2-1
|
本帖最後由 c_c_lai 於 2016-8-6 11:52 編輯
回復 12# VBALearner - Option Explicit
- Option Base 1
- Sub 調整儲存格大小()
- Dim cts As Integer
-
- For cts = 1 To Sheets.Count
- With Sheets(cts)
- .Activate
- .Columns.ColumnWidth = 10
- .Rows.RowHeight = 15
- End With
- Next
- End Sub
- Sub 批量匯入買賣超與價格()
- Call 上市上櫃交易("上市外資", "上市投信", 4, 7, "201*") ' 批量匯入買賣超
- Call 上市上櫃交易("上櫃外資", "上櫃投信", 4, 7, "BIG*") ' 批量匯入價格
- Call 上市上櫃交易("上市收盤價", "", 8, 0, "A112201*") ' 更新買賣超
- Call 上市上櫃交易("上櫃收盤價", "", 2, 0, "SQUOTE*") ' 更新價格
- Beep
- End Sub
- Sub 上市上櫃交易(tbl As String, tbl2 As String, pos1 As Integer, pos2 As Integer, typ As String, Optional auto As Boolean = False)
- Dim myFile As String, myDate As String
- Dim rng As Range, stkNo As Variant
- Dim wb As Workbook
- Dim cts As Long, xs As Long
-
- Application.ScreenUpdating = False
- xs = Sheets(tbl).Range("A" & Rows.Count).End(xlUp).Row
- ReDim tget2(xs - 1) As Long
- If pos2 > 0 Then
- ReDim tget3(xs) As Long
- End If
- stkNo = Application.Transpose(Range(Sheets(tbl).Range("A2"), Sheets(tbl).[A2].End(xlDown)))
-
- myFile = Dir("C:\三大法人更新區\" & typ)
- Do While myFile <> ""
- Workbooks.Open "C:\三大法人更新區\" & myFile
- Select Case typ
- Case "201*" ' (20160802_2by_issue.csv)
- myDate = Left(myFile, 8)
- Case "BIG*" ' (BIGD_1050802.csv)
- myDate = Mid(myFile, 6, 7): myDate = CStr((Val(Left(myDate, 3)) + 1911)) + Mid(myDate, 4, 4)
- Case "A112201*" ' (A11220160802ALL.csv)
- myDate = Mid(myFile, 5, 8)
- Case "SQUOTE*" ' (SQUOTE_AL_1050802.csv)
- myDate = Mid(myFile, 11, 7): myDate = CStr((Val(Left(myDate, 3)) + 1911)) + Mid(myDate, 4, 4)
- End Select
-
- myDate = Left(myDate, 4) + "/" + Mid(myDate, 5, 2) + "/" + Right(myDate, 2)
-
- myFile = Dir '第二次調用Dir函數而不帶任何參數，則會返回至同一目錄下的下一個文件
-
- Set wb = ActiveWorkbook
- With Sheets(1)
- For cts = 1 To xs - 1
- Set rng = .Range("A:A").Find(stkNo(cts))
- If Not rng Is Nothing Then
- tget2(cts) = IIf(IsNumeric(rng.Offset(0, pos1).Value), rng.Offset(0, pos1).Value, 0) ' (0, 8)
- If pos2 > 0 Then tget3(cts) = IIf(IsNumeric(rng.Offset(0, pos2).Value), rng.Offset(0, pos2).Value, 0) ' (0, 7)
- Else
- tget2(cts) = 0
- If pos2 > 0 Then tget3(cts) = 0
- End If
- Next
- End With
- wb.Close SaveChanges:=False
-
- With Sheets(tbl)
- .Activate
- Set rng = Range(.[A1], .[A1].End(xlToRight)) ' 從 A 欄至最右欄位範圍
- Set rng = rng.Find(CDate(myDate), LookIn:=xlValues, LookAt:=xlWhole)
- If rng Is Nothing Then
- .Range("C:C").Insert
- Set rng = .[C1]
- rng.Value = myDate
- End If
- ' Range(.Range("C2"), .Range("C" & .[A2].End(xlDown).Row)) = Application.Transpose(tget2)
- Range(rng.Offset(1), .Range(Chr(64 + rng.Column) & .[A2].End(xlDown).Row)) = Application.Transpose(tget2)
- End With
-
- If tbl2 <> "" Then
- With Sheets(tbl2)
- .Activate
- Set rng = Range(.[A1], .[A1].End(xlToRight)) ' 從 A 欄至最右欄位範圍
- Set rng = rng.Find(CDate(myDate), LookIn:=xlValues, LookAt:=xlWhole)
- If rng Is Nothing Then
- .Range("C:C").Insert
- Set rng = .[C1]
- rng.Value = myDate
- End If
- ' Range(.Range("C2"), .Range("C" & .[A2].End(xlDown).Row)) = Application.Transpose(tget3)
- Range(rng.Offset(1), .Range(Chr(64 + rng.Column) & .[A2].End(xlDown).Row)) = Application.Transpose(tget3)
- End With
- End If
- Loop
-
- Application.ScreenUpdating = True
- End Sub
|
|
發表於 2016-8-5 14:49
| 
