- 帖子
- 4
- 主題
- 1
- 精華
- 0
- 積分
- 7
- 點名
- 0
- 作業系統
- windows7
- 軟體版本
- office2003
- 閱讀權限
- 10
- 註冊時間
- 2016-3-25
- 最後登錄
- 2016-4-9
|
我有一個檔案，裡面有數個sheet，需要以各個sheet內的C3為命名建立數個資料夾，再把它們全部丟入以Q3為命名的資料夾內，我剪剪貼貼後得到了我要的效果，可是它們全部都丟在桌面，並沒有全部都都入以Q3為名的資料夾內
Sub LL()
Sheets.Add
Sheets("Sheet1").Name = "TOTAL"
Sheets("TOTAL").Move Before:=Sheets(1)
Dim i, j As String
Dim sh As String
i = 1 'total sheet 從第二列開始
For n = 1 To ActiveWorkbook.Sheets.Count '總共有幾張sheet
sh = "N" '工作表名稱
Worksheets(n).Select '選擇某頁工作表
Value1 = Range("C3").Value '需彙總的儲存格值分別放入各個變數
Worksheets("TOTAL").Select '選擇TOTAL sheet
Range("A" & i).Value = Value1 '將各個變數值分別放入儲存格位置
i = i + 1 '彙總頁total往下新增一列 N頁明細表就有N列資料
Next
Cells.Replace What:=" ", Replacement:="-", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="--", Replacement:="-", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="/", Replacement:="(", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="-(", Replacement:="(", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
For i = 2 To n - 1
Range("A" & i).Value = Range("A" & i).Value & ") PCS"
Next
Cells.Replace What:="-)", Replacement:=")", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Sheets("1").Select
Range("Q3").Copy
Sheets("TOTAL").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim strPath, strFolderName
Dim objFS, objFloder, objFC
strPath = "C:\Users\tod210\Desktop\"
strFolderName = Range("A1").Value
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFC = objFolder.SubFolders
objFC.Add (strFolderName)
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim folder As String
folder = ThisWorkbook.Path & "\"
Dim NX As Long, X As Long, NM As String
NX = [A65536].End(xlUp).Row
For X = 2 To NX
NM = Cells(X, 1).Value
If NM = "" Then GoTo nextname
FSO.CreateFolder (folder & NM)
nextname:
Next
End Sub |
-
-
061025.rar
(13.5 KB)
|
發表於 2016-3-26 00:05
| 
