- 帖子
- 1018
- 主題
- 15
- 精華
- 0
- 積分
- 1058
- 點名
- 0
- 作業系統
- win7 32bit
- 軟體版本
- Office 2016 64-bit
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 桃園
- 註冊時間
- 2012-5-9
- 最後登錄
- 2022-9-28
|
回復 49# happycoccolin - Sub TEST()
- Dim ar, r As Long, i As Long
- Dim cIndexOld, cIndexNew, arNewHeader
- Dim f, findTitle
-
- cIndexOld = Array(2, 3, 4, 5, 7, 8) 'A檔案中要搬動的欄
- cIndexNew = Array(2, 4, 21, 24, 43, 44) '搬到B檔位置
- arNewHeader = Array("Q", "W", "E", "R", "T", "Y", "U", "I") '自己填全部B檔標題名稱
-
- f = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇來源檔案")
- If Not TypeName(f) = "String" Then Exit Sub '取消則結束
-
- Application.ScreenUpdating = False
- With Workbooks.Open(f)
- With .Sheets(1)
- Set findTitle = .Cells.Find("Item", , xlValues, xlWhole, xlByRows, xlNext) '找標題 Item
- If findTitle Is Nothing Then MsgBox "找不到標題": Exit Sub
-
- With findTitle.CurrentRegion
- ar = .Parent.Range(findTitle, .Cells(.Rows.Count, .Columns.Count)).Value
- End With
- End With
- .Close False
- End With
- Application.ScreenUpdating = True
-
- r = UBound(ar)
- With Workbooks.Add
- With .Sheets(1)
- For i = LBound(cIndexOld) To UBound(cIndexOld)
- .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
- Next
- .[A1].Resize(, UBound(arNewHeader) + 1).Value = arNewHeader
- End With
-
- If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
- f = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
- If Not TypeName(f) = "String" Then Exit Sub '取消則結束
- .SaveAs f, FileFormat:=xlWorkbookDefault
- End If
- End With
- End Sub
|
|
發表於 2013-8-15 17:46
| 
