3 filtre pe valori unice + export

RazvanManolea
Mesaje: 1
Membru din: Vin Sep 14, 2018 11:18 am

3 filtre pe valori unice + export

Mesaj de RazvanManolea » Vin Sep 14, 2018 11:23 am

Trebuie sa aplic 3 filtre pe 3 coloane diferite pentru a selecta toate combinatiile unice posibile si mai apoi sa export fiecare varianta intr-un excel nou. Am folosit urmatorul cod pentru a filtra valorile unice de pe o singura coloana dar nu reusesc deloc sa aplic cele 3 filtre si sa reusesc sa imi exporte. Ceva sugestii?

Cod: Selectaţi tot

Sub Main_Button5_Click()

'Declare variables
Dim ArrayItem As Long
Dim ws As Worksheet
Dim ArrayOfUniqueValues As Variant
Dim SavePath As String
Dim ColumnHeadingInt As Long
Dim ColumnHeadingStr As String
Dim rng As Range

'Set the worksheet to
Set ws = Sheets("Main")

'Set the save path for the files created
SavePath = Range("FolderPath")

'Set variables for the columns we want to separate data based on
ColumnHeadingInt = WorksheetFunction.Match(Range("ExportCriteria").Value, Range("Data[#Headers]"), 0)
ColumnHeadingStr = "Data[[#All],[" & Range("ExportCriteria").Value & "]]"


'Turn off screen updating to save runtime
Application.ScreenUpdating = False

'Create a temporary list of unique values from the column we want to
'separate our data based on
Range(ColumnHeadingStr & "").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("UniqueValues"), Unique:=True

'Sort our temporary list of unique values
ws.Range("UniqueValues").EntireColumn.Sort Key1:=ws.Range("UniqueValues").Offset(1, 0), _
    Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Add unique field values into an array
'ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("IV2:IV" & Rows.Count).SpecialCells(xlCellTypeConstants))
ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("UniqueValues").EntireColumn.SpecialCells(xlCellTypeConstants))

'Delete the temporary values
ws.Range("UniqueValues").EntireColumn.Clear

'Loop through our array of unique field values, copy paste into new workbooks and save
For ArrayItem = 1 To UBound(ArrayOfUniqueValues)
    ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
    ws.Range("Data[#All]").SpecialCells(xlCellTypeVisible).Copy
    Workbooks.Add
    Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    'Rows(1).EntireRow.Delete
   
   
   
    ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & Format(Now(), " YYYY-MM-DD hhmmss") & ".csv", FileFormat:=xlCSV, local:=True
    ActiveWorkbook.Close False
    ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt
Next ArrayItem

ws.AutoFilterMode = False
MsgBox "Finished exporting!"
Application.ScreenUpdating = True
    


End Sub
Ultima oară modificat Vin Sep 14, 2018 11:34 am de către IPP, modificat 1 dată în total.
Motiv: Adaugare TAG Code

TudyBTH
Moderator
Moderator
Mesaje: 904
Membru din: Joi Feb 11, 2016 2:12 pm
Localitate: Cluj Napoca

Re: 3 filtre pe valori unice + export

Mesaj de TudyBTH » Vin Sep 14, 2018 1:58 pm

Atasati intregul fisier daca doriti sa primiti un raspuns la mesaj.
A deduce formatul fisierului din cod presupune un volum de munca pe care este putin probabil sa si-l asume cineva.
Am invatat sa inotam in apa, ca pestii
Am invatat sa zburam in aer, ca pasarile
A ramas doar sa invatam sa traim pe Pamant, ca Oamenii.

Scrie răspuns

Înapoi la “Visual Basic for Application (VBA) cu Excel - Intrebari tehnice”