麻辣家族討論版版 - Powered by Discuz! Board

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

複製代碼