Question

我有两个不同的唯一值（X，Y），到目前为止我已经完成了。我想在条件x<>y不相等的情况下将剩余的唯一值放在数组中，并且需要创建一个包含数组值的工作簿（其余的唯一值）。

前：

X               Y
SAP           Siemens
Siemens       otto
Otto          Allianz AG
Accenture     Oracle
Oracle        Capgemini
TCS           Daimler
Infosys       Akka

我已经将工作簿作为＆＃34; Siemens.xlsx＆＃34;，＆＃34; Oracle.xlsx＆＃34;，＆＃34; Otto.xlsx＆＃34;。现在我需要数组中Y列的其余唯一值。我的预期结果应该是＃34; Akka.xlsx＆＃34;，＆＃34; Allainz AG。 xlsx＆＃34;，＆＃34; Daimler.xlsx＆＃34;。

代码：

Sub array()

    Dim y as range
    Dim c as integer
    Dim Lastrow_Y As Integer
    Dim Lastrow_X As Integer
    Dim rngFilter_Y as range
    Dim rngCopy as range
    Dim NewBook as workbook

    With Master_workbook.Worksheets("FBI")
            Sheets("FBI").Columns("C:C").AdvancedFilter Action:=xlFilterCopy, _
             CopyToRange:=.Range("AZ1"), Unique:=True
             Lastrow_Y = .Cells(.Rows.Count, "AY").End(xlUp).Row
   End with

   With Master_workbook.Worksheets("WWF")
            Sheets("WWF").Columns("d:d").AdvancedFilter Action:=xlFilterCopy, _
             CopyToRange:=.Range("AY1"), Unique:=True
             Lastrow_X = .Cells(.Rows.Count, "AY").End(xlUp).Row
   End with

    For c = 2 To Lastrow_Y
                    Set y = Master_workbook.Sheets("FBI").Range("AZ" & c)
                    Set x = Master_workbook.Sheets("WWF").Range("AY" & c) 
                        If x = y Then
                        set NewBook = workbooks.add
                            with NewBook 
                              .Title = y    NewBook.Worksheets.Add(After:=.Sheets(.Sheets.Count)).Name = "www"
                             With rngFilter_Y

                                    .AutoFilter field:=32, Criteria1:="<>(a)  0 - 360", Operator:=xlFilterValues
                                    .AutoFilter field:=37, Criteria1:=y.Value, Operator:=xlFilterValues

                                    Set rngCopy = .SpecialCells(xlCellTypeVisible)
                                                        .AutoFilter ' Switch off AutoFilter
                             End With
                        .SaveAs Filename:= Y & ".xlsx"

                         rngCopy.Copy NewBook.Worksheets("www").Cells(1, 1)

                        Else
                        End If
       Next    

    End sub

如果有人帮我解决这个问题，我真的很感激。

Answer 1

在我看来，检查当前文件夹中已经创建的文件要容易得多，然后只创建Y范围内尚未存在的文件？

Option Explicit

Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim folder : Set folder = fso.GetFolder(<path to your .xlsx files here>)
Dim file, fileNames, lastRowY, row, checkFile, newBook
For Each file in folder.Files
    If Right(file.Name, 4) = "xlsx" Then
        fileNames = fileNames & file.Name & ";"         ' will give a list of all filenames
    End If
Next

With Master_workbook.Worksheets("FBI")
       lastRowY = .Cells(.Rows.Count, "AY").End(xlUp).Row
End With

For row = 2 to lastRowY
    checkFile = Master_workbook.Worksheets("FBI").Range("AY").Value
    If Instr(fileNames, checkFile) = 0 Then
       Set newBook = Workbooks.Add
       ' do whatever with newBook
       newBook.SaveAs (checkFile & ".xlsx")
       newBook.Close
    End If
Next

如果使用vba excel条件不相等，如何将其余的唯一值放入数组中

1 个答案: