创建公式的脚本不使用Excel VBA

Question

这是使用excel电子表格将excel文档导入到creatung文件夹的整个脚本。

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 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

Error http://www.kaboomlabs.com/excel/img/error6.jpg

现在如上所示，应该清理C3。如果有人知道发生了什么事，那就会非常谨慎。不，我也没有这个受保护，锁定或其他任何东西的文件夹。我昨天创建了这个文件夹，希望能让它正常工作......

脚本和信息都在这里：CreateFolder Sheet and scripts

Answer 1

尝试将代码更改为

    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

Answer 2

没问题

问题是您创建文件夹的方式只允许您一次创建一个文件夹。所以你需要建立路径，可能是这样的：

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

这将创建任何深度的路径。

Answer 3

好吧，我用一个旧脚本，在工作簿单元格中添加了更多东西，但它也按照我需要的方式工作。

以下是代码：

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,",","")," "," "),".",""),"/","-"),"""",""),"*",""))

这会修剪我们看不到的任何空白区域的所有单元格的末尾，并清理单元格以使其准确并且可以在其中创建文件夹。