Oscar Sun

                    Sub 檔案重新命名()
Dim fs, fc, fl, f ', OldName As String, NewName As String
'p = ""InputBox("請輸入路徑", , p)
Const p = "C:\Documents and Settings\xxx\My Documents\My Pictures\reName" '"請輸入路徑"
'If Dir(p) = "" Then MsgBox "請檢查路徑": Exit Sub
Const o = "!!" '被取代字串
Const n = "@@@" '取代字串

Const 卷 = "14"
Const 新檔起始號 = 177

'Const 原檔起始號 = 1 '均先批次重新命名為１開始
Const 副檔名 = ".jpg"
If p = "" Then Exit Sub


Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(p)
Set fc = f.Files
'原檔起始號 = CLng(Mid(fc.Item(1), 2))
For Each fl In fc
    原檔起始號 = CLng(Mid(Replace(fl.Name, 副檔名, ""), 2))
    Exit For
Next
For i = 0 To fc.Count - 1
    If (i + 1) Mod 2 = 0 Then
        fc(Format(i + 原檔起始號, "a000000" & 副檔名)).Name = Format(卷, "00000") & "_" & Format(Int(i / 2) + 新檔起始號, "000000" & "b" & 副檔名)
    Else
        fc(Format(i + 原檔起始號, "a000000" & 副檔名)).Name = Format(卷, "00000") & "_" & Format(Int(i / 2) + 新檔起始號, "000000" & "a" & 副檔名)
    End If
Next i
'For Each fl In fc
'    fl.Name = Replace(fl.Name, o, n)
'
'Next fl
End Sub


                  

                    Sub 檢查註釋編號()
Dim r As Range, a, flg As Boolean
On Error Resume Next
For Each a In ThisDocument.Characters
    If a.Font.ColorIndex = 0 And StrComp(a, Chr(19)) = 0 Then
        a.Select
        n = 0
        n1 = 0
'        Stop
    End If
    If a.Font.ColorIndex = 6 Then 'wdRed
        a.Select
        If Selection.End > 26882 Then
            If Len(Selection) >= 16 And flg = False Then
                n = Replace(Replace(Mid(Selection, InStr(Selection, "○,") + 2), ")", ""), Chr(21), "")
                flg = True

                ed = Selection.End
                'Selection.Collapse wdCollapseEnd
            ElseIf Len(Selection) >= 16 And flg Then
                If Selection.End > ed And ed <> Empty Then
                    n1 = Replace(Replace(Mid(Selection, InStr(Selection, "○,") + 2), ")", ""), Chr(21), "")
                    If n1 - n <> 1 Then 'And n1 - n <> 0 Then
                        If a.Previous.Previous <> Chr(-24235) Then
                            Beep
                            Stop
                        End If
                    End If
                    flg = False
                End If
            End If
    '        Selection.MoveEndWhile "}"
    '        do while
        End If
    End If
Next a
'Selection.Find.Execute "eq \o\ac(○," & i & ")"
'
'Selection.SetRange InStr(ThisDocument.Range, "eq \o\ac(○,1)"), InStr(ThisDocument.Range, "eq \o\ac(○,1)") + 16
'r.Select
MsgBox "done!", vbInformation
End Sub


                  

                    Sub 資料比對_將另一個活頁簿資料插入本地活頁簿() '2016/3/31
Dim wb As Workbook, wbNew As Workbook, st As Worksheet, stNew As Worksheet, x As String
Dim clm As Integer, clmOrn As Integer, c As Object, cNew As Object
Dim i As Integer, j As Integer, clmNewText As String
Set wb = Workbooks(1) '先開要插入的活頁簿(來源excel檔)'來源與目的二活頁簿均須有欄名一列
Set st = wb.Sheets(1)
Set wbNew = Workbooks(2) '再開要被插入新資料的活頁簿(目的excel檔)
Set stNew = wbNew.ActiveSheet
clmOrn = st.UsedRange.Columns.Count
clm = stNew.UsedRange.Columns.Count + 1 '一律從最右新欄位插入資料
cct = st.UsedRange.Columns(1).Cells.Count - 1
cnewct = stNew.UsedRange.Columns(1).Cells.Count - 1
For Each c In st.UsedRange.Columns(1).Cells '一律以第1欄作為資料比對欄'所以來源EXCEL檔必須要二欄以上
    If c.Row > 1 Then '新待插入之資料必須有欄名
'        If c.Row Mod 5000 = 0 Then stNew.Parent.Save ': Stop
        x = c.Text
'        If c.Row > 2 Then
'            If InStr(clmNewText, c) > 0 Then '目的欄位存在比對,才進行尋找插入位置
'                GoTo 11
'            Else
'                GoTo 12
'            End If
'        End If
11
'        Beep
'        Set cNew = stNew.UsedRange.Columns(1).Find(c) '要改成不找第一列!!
        'Set cNew = stNew.Range("A2:A" & cnewct + 1).Find(c) '不找第一列!!
        Set cNew = stNew.Range(stNew.Cells(2, 1), stNew.Cells(cnewct + 1, 1)).Find(c, LookAt:=xlWhole, MatchCase:=True) '不找第一列!!
        If Not cNew Is Nothing Then
        
'            cNew.Select
'            Beep
'            Stop
'            stNew.Activate
'            stNew.Cells(cNew.Row, clm + j).Select
'            Stop
'
'            If cNew.Address = "$A$1" Then '若為第一列則找下一筆!
'                beep
'                Stop
'                Set cNew = stNew.UsedRange.Columns(1).FindNext
'                If cNew Is Nothing Then flg = False: GoTo 12
'            End If
            If stNew.Cells(cNew.Row, clm + j) <> "" Then
                stNew.Activate
                beep
'                Stop
                st.Activate
                st.Cells(c.Row, 1).Select
'                Stop
                st.Cells(c.Row, clmOrn + 1) = st.Cells(c.Row, clmOrn + 1).Text & "§"   '尋找失誤的資料則註記之,以備檢
            End If
            
            For i = 2 To clmOrn '因為第一欄不插入,所以要從2開始!
                stNew.Cells(cNew.Row, clm + j) = st.Cells(c.Row, i)
                j = j + 1
            Next
            flg = True
            j = 0
            
'            Stop
            s = s + 1
        Else
            t = t + 1
            beep
'            MsgBox "CHECK!!", vbExclamation
'            Stop
            flg = False
            GoTo 12
        End If
'        For Each cNew In stNew.UsedRange.Columns(1).Cells '一律以第1欄作為資料比對欄
'            If cNew.Row > 1 Then '待被插入之資料必須有欄名
'                If StrComp(cNew.Text, x) = 0 Then
'
''                    stNew.Activate
''                    stNew.Cells(cNew.Row, clm + j).Select
''                    Stop
'
'                    For i = 2 To clmOrn
'                        stNew.Cells(cNew.Row, clm + j) = st.Cells(c.Row, i)
'                        j = j + 1
'                    Next
'                    j = 0
'                    flg = True
'
''                    Stop
'
'                    If c.Row > 2 Then Exit For
'                End If
'            End If
'            If c.Row = 2 Then clmNewText = clmNewText & cNew.Text '記下目的地比對欄內的值,以供快速比對
''            Application.StatusBar = "搜尋第" & cNew.Row & "/" & cnewct & "筆!" & vbTab & "第" & c.Row & "/" & cct & "已插入!"
''            Application.StatusBar = "搜尋第" & cNew.Row & "/" & "82131筆!" & vbTab & "第" & c.Row & "/" & "81052已插入!"
'        Next
12
        If flg = False Then '如果要插入的來源資料在目的地無對應的話
'            MsgBox "CHECK!!!!!!", vbExclamation
'            st.Activate
'            st.Cells(c.Row, 1).Select
'            Stop
            st.Cells(c.Row, clmOrn + 1) = st.Cells(c.Row, clmOrn + 1).Text & "◎" '沒有對應到的資料則註記之,以備檢
        End If
'        flg = False
    End If
    'oldStatusBar = Application.DisplayStatusBar'https://msdn.microsoft.com/zh-tw/library/office/ff835916(v=office.15).aspx
    'Application.DisplayStatusBar = True
    If (c.Row - 1) Mod 100 = 0 Or c.Row = cct + 1 Then Application.StatusBar = "第" & c.Row - 1 & "/" & cct & "已插入!"
'    Workbooks.Open Filename:="LARGE.XLS"
'    Application.StatusBar = False
'    Application.DisplayStatusBar = oldStatusBar
    u = u + 1
Next
If MsgBox("done!!" & vbCr & vbCr & "是否存檔?", vbInformation + vbYesNo + vbDefaultButton2) = vbYes Then
    If wbNew.Saved = False Then
    '    Stop
        wbNew.Save
    End If
    If wb.Saved = False Then
    '    Stop
        wb.Save
    End If
End If
Set c = Nothing
Set cNew = Nothing
Set wb = Nothing
Set wbNew = Nothing
Set st = Nothing
Set stNew = Nothing
Debug.Print "s=" & s & vbTab & "t=" & t & vbTab & "u=" & u
End Sub

                  

                    Sub 資料夾重新命名()
Dim fs, fc, fl, f ', OldName As String, NewName As String
'p = ""InputBox("請輸入路徑", , p)
Const p = "X:\!!來自H筆電第3批" '"請輸入路徑"
'If Dir(p) = "" Then MsgBox "請檢查路徑": Exit Sub
Const o = "!!" '被取代字串
Const n = "@@@" '取代字串
If p = "" Then Exit Sub
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(p)
Set fc = f.subFolders '.Files
For Each fl In fc
    fl.Name = Replace(fl.Name, o, n)
    
Next fl
End Sub

                  

                    Sub s()
'CJK兼容      [F900-FAD9]        474字  豈更車賈滑串句龜龜
'CJK兼容?展  [2F800-2FA1D]      542字  ??????????????????
''
For i = &H2F00 To &H2FDF
    
'For i = &HF900 To &HFAFF
'    ss = Selection.Start
    Selection.TypeText Hex(i)
'    ee = Selection.Start
'    Selection.SetRange ss, ee
'    Selection.ToggleCharacterCode
    Selection.InsertParagraphAfter
    Selection.Collapse wdCollapseEnd
Next
End Sub