I need a macro to take the different values from column C of a workbook and compile the unique ones, either on the same sheet, new sheet or in a new workbook.
For example Col. C may contain 50 rows of the value 'Excel2' and 150 values of 'Word2', I would just need the Excel2 and Word2 to be shown somewhere, just once. Perhaps in a new sheet/workbook stating the column C header.
This is my macro so far, maybe altering the 'lrng.formula' part would help:
Sub Calculationallsheetsv2()
'Calculation all sheets, even when there is only headers
Dim xrng As Range, lrw As Long, lrng As Range, i As Long
Dim LstCo As Long, ws As Worksheet
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
For Each ws In ActiveWorkbook.Worksheets
With ws
If Not Application.WorksheetFunction.CountA(.Cells) = 0 Then
LstCo = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
For i = 1 To LstCo
With .Columns(i)
.TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, TrailingMinusNumbers:=True
End With
Next
lrw = .Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).Row
If lrw = 1 Then lrw = 2
Set lrng = .Range("A" & lrw + 2)
With .Range("A2:A" & lrw)
lrng.Formula = "=COUNTA(" & .Address(0, 0) & ")/ROWS(" & .Address(0, 0) & ")"
End With
Set xrng = .Range(lrng, .Cells(lrng.Row, LstCo))
lrng.AutoFill xrng, Type:=xlFillDefault
xrng.Style = "Percent"
End If
End With
Next
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
Application.CalculateFull
End With
End Sub
You can just use Excel's built-in AdvancedFilter feature to do this. For example, this grabs the unique values from column C on Sheet1 and puts them in column C on Sheet3:
Sheet1.Range("C:C").AdvancedFilter xlFilterCopy, , Sheet3.Range("C1"), True
Related
I have this Macro which essentially uses two sheets - sheet2 updates sheet1 and then kills the second worksheet.
I noticed that when it comes to one part of the macro (delete row which has "Delete" in column A in worksheet 1) it doesn't appear to work if I run the Macro from worksheet 2. If I run it from Sheet 1 is works without a problem.
This is the full code, just in case you need to look at it - I'll highlight the part that I'm having trouble with next.:
Public Sub Cable_Load_full()
'~~> Copy New Accounts from worksheet2
Dim ws1 As Worksheet, ws2 As Worksheet
Dim bottomL As Integer
Dim x As Integer
Dim c As Range
Dim i As Long, J As Long, LastCol As Long
Dim ws1LR As Long, ws2LR As Long
Dim ws1Rng As Range, aCell As Range
Dim SearchString
Set ws1 = Sheets("CableSocials")
Set ws2 = Sheets("CableRevised")
bottomL = ws2.Range("A" & Rows.Count).End(xlUp).Row: x = 1
x = ws1.Range("A" & Rows.Count).End(xlUp).Row
x = x + 1
For Each c In ws2.Range("A1:A" & bottomL)
If c.Value = "New" Then
c.EntireRow.Copy ws1.Range("A" & x)
x = x + 1
End If
Next c
'~~> Assuming that ID is in Col B
'~~> Get last row in Col B in Sheet1
ws1LR = ws1.Range("B" & Rows.Count).End(xlUp).Row
'~~> Set the Search Range
Set ws1Rng = ws1.Range("B1:B" & ws1LR)
'~~> Adding Revise Column to worksheet 1
ws1.Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Value = "Revise"
Set ws2 = Sheets("CableRevised")
'~~> Turn off Filter
ws2.AutoFilterMode = False
'~~> Get last row in Col A in Sheet2
ws2LR = ws2.Range("B" & Rows.Count).End(xlUp).Row
'~~> Loop through the range in Sheet 2 to match it with the range in Sheet1
For i = 1 To ws2LR
SearchString = ws2.Range("B" & i).Value
'~~> Search for the ID
Set aCell = ws1Rng.Find(What:=SearchString, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> If found
If Not aCell Is Nothing Then
'~~> Append values
ws1.Cells(aCell.Row, 1).Value = ws2.Cells(i, 1).Value
ws1.Cells(aCell.Row, 3).Value = ws2.Cells(i, 2).Value
ws1.Cells(aCell.Row, 19).Value = ws2.Cells(i, 18).Value
ws1.Cells(aCell.Row, 20).Value = ws2.Cells(i, 19).Value
End If
Next i
'~~> Delete the accounts that need to be deleted
ws1.AutoFilterMode = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, "Delete"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
ws1.AutoFilterMode = False
'~~> Removing New from Column B
ws1.Columns("B").Replace What:="New", _
Replacement:="", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
ws1.Columns("A").EntireColumn.Delete
Call SheetKiller
End Sub
Sub SheetKiller()
Dim s As Worksheet, t As String
Dim i As Long, K As Long
K = Sheets.Count
For i = K To 1 Step -1
t = Sheets(i).Name
If t = "CableRevised" Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
End If
Next i
End Sub
So the part that only works when I run the Macro from Sheet1 is:
'~~> Delete the accounts that need to be deleted
ws1.AutoFilterMode = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, "Delete"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
ws1.AutoFilterMode = False
I'm not sure why - is it acting as if it will only delete the rows from the ActiveSheet (which I guess would be the Sheet I run the Macro from?) ? Is it possible to make it work even if I run the Macro from Sheet2?
Thanks for any help you provide!
You need to explicitly refer to ranges on ws1. As written, your code is looking for ranges on the active sheet.
Try this:
'~~> Delete the accounts that need to be deleted
ws1.AutoFilterMode = False
With ws1.Range("A1", ws1.Range("A" & ws1.Rows.Count).End(xlUp))
.AutoFilter 1, "Delete"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
ws1.AutoFilterMode = False
I am currently in the process of creating a VBA Script where i extract a list of raw data and filter out values Apple, Banana, and Oranges. I then delete all the other rows if it is not the values mentioned above.
So for example i have apple, banana, orange, grape, mandarin, avocado, coconut, lemon, watermelon.
I only want to keep apple, banana and orange in the end. If it has any of the other fruits i want that whole row of information removed.
Sub RMWO_Clean()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Range("Q" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("Q1:Q" & lastRow)
Columns("AF:AF").Select
Selection.TextToColumns Destination:=Range("AA1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
With rng
.AutoFilter Field:=1,Criteria1:="<>*Apple*", Operator:=xlAnd, Criteria2:="<>*Banana*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ws.AutoFilterMode = False
End Sub
I know that you cannot use
Criteria3:=xx
I have also tried
Criteria1:=Array("<>Apple", "<>Banana", "<>Orange")
But this seems to only leave orange behind.
Are you able to let me know what i am doing wrong?
Criteria1:=Array("<>Apple", "<>Banana", "<>Orange") needs Operator:=xlFilterValues operator, and yet won't work with those "<>"
so you can fool it by thinking the other way around:
filter "good" records
delete all records that are not good
like follows:
With rng
.AutoFilter Field:=1, Criteria1:=Array("Apple", "Banana", "Orange"), Operator:=xlFilterValues
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) ' reference 'records' only (skip headers)
Select Case Application.Subtotal(103, .Cells) ' count number of filtered cells
Case 0 'if no cells to save
.EntireRow.Delete ' delete all rows
Case Is < .Count 'if there's at least one row to delete
Set saveRng = .SpecialCells(xlCellTypeVisible) ' store cells to save
.Parent.AutoFilterMode = False 'remove filter
saveRng.EntireRow.Hidden = True 'hide cells to save
.SpecialCells(xlCellTypeVisible).EntireRow.Delete 'delete visible cells
saveRng.EntireRow.Hidden = False 'bring cells to save visible back
End Select
End With
.Parent.AutoFilterMode = False
End With
Starting with:
I run:
Dim myRange As Range
Set myRange = ActiveSheet.Range("$A$1:$A$4")
myRange.AutoFilter Field:=1, _
Criteria1:="<>*Banana*", Operator:=xlAnd, Criteria2:="<>*apple*"
...and I get:
...and then I run:
myRange.AutoFilter Field:=1
...and I get:
I can delete the non-filtered rows with:
Rows("2:7").Delete Shift:=xlUp
Putting it all together, you could do something like:
Sub DeleteRowsExceptApplesAndBananas()
Const startCell = "A1"
Dim rgFilter As Range
'get range to filter
With Sheets("Sheet1")
Set rgFilter = Range(.Range(startCell), .Range(startCell).End(xlDown))
'set filter
rgFilter.AutoFilter 1, "<>*Banana*", xlAnd, "<>*apple*"
'delete rows beginning one below startCell's row
Range(.Range(startCell).Offset(1).Row & ":" & _
.Range(startCell).End(xlDown).Row).Delete (xlUp)
'un-filter
rgFilter.AutoFilter 1
End With
End Sub
It doesn't seem to me that Range.AutoFilter will do what you want it to here, precisely because you can only use two criteria for it.
I'd personally prefer to solve this problem with a loop operation, like so:
Option Compare Text
Sub Macro1()
Dim ws As Worksheet
Dim rng As Range
Dim col As String
Dim i As Integer
Set ws = ActiveWorkbook.Sheets("Sheet1")
col = "A"
i = 1
Set rng = ws.Range(col & i)
Do
Select Case rng.FormulaR1C1
Case "apple", "orange", "banana"
i = i + 1
Case Else
rng.Delete xlShiftUp
End Select
Set rng = ws.Range(col & i)
Loop Until rng.FormulaR1C1 = ""
End Sub
The code above assumes that you've already done all the preprocessing you've needed to do to extract your list of fruits, and that that list begins in cell A1 of Sheet1, although you can of course modify that code to put the list anywhere you'd like.
Version 1 bellow uses a "reverse" AutoFilter
Version 2, moves all rows to keep to a new sheet, and deletes the old (very fast for a lot of rows)
.
Version 1
Option Explicit
Public Sub DeleteRowsForCriteria()
Const FILTER_COL = "Q"
Const To_KEP = "apple banana orange"
Dim ws As Worksheet, lr As Long
Set ws = Sheet1 'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, FILTER_COL).End(xlUp).Row
Application.ScreenUpdating = False
ws.Range("AF1:AF" & lr).TextToColumns Destination:=ws.Range("AA1"), _
TextQualifier:=xlDoubleQuote, _
FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
Dim filterCol As Range, toKep As Variant, keep As Range
Set filterCol = ws.Range("Q1:Q" & lr)
toKep = Split(To_KEP)
With filterCol 'Reverse Filter - show all rows to keep ("apple banana orange")
.AutoFilter Field:=1, Criteria1:=toKep, Operator:=xlFilterValues
If .SpecialCells(xlCellTypeVisible).Count > 1 Then
Set keep = .SpecialCells(xlCellTypeVisible).EntireRow
End If
.AutoFilter 'Unhide all rows
keep.Rows.Hidden = True 'Hide all rows to keep ("apple banana orange")
.SpecialCells(xlCellTypeVisible).EntireRow.Delete 'Delete unwanted (now visible)
End With
keep.Rows.Hidden = False 'Unhide rows to keep ("apple banana orange")
Application.ScreenUpdating = True
End Sub
.
Version 2
Public Sub DeleteRowsForCriteriaFast()
Const FILTER_COL = "Q"
Const To_KEP = "apple banana orange"
Dim ws1 As Worksheet, ws2 As Worksheet, lr As Long, wsName As String, keep As Range
Set ws1 = Sheet1 'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
lr = ws1.Cells(ws1.Rows.Count, FILTER_COL).End(xlUp).Row
Application.ScreenUpdating = False
ws1.Range("AF1:AF" & lr).TextToColumns Destination:=ws1.Range("AA1"), _
TextQualifier:=xlDoubleQuote, _
FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
Dim filterCol As Range, toKep As Variant
Set filterCol = ws1.Range("Q1:Q" & lr)
toKep = Split(To_KEP)
Application.DisplayAlerts = False
Set ws2 = ThisWorkbook.Worksheets.Add(After:=ws1)
wsName = ws1.Name
With filterCol
.AutoFilter Field:=1, Criteria1:=toKep, Operator:=xlFilterValues
If .SpecialCells(xlCellTypeVisible).Count > 1 Then
.EntireRow.Copy
ws2.Cells.PasteSpecial xlPasteColumnWidths
ws2.Cells.PasteSpecial xlPasteAll 'Paste data on new sheet
ws1.Delete: ws2.Name = wsName: ws2.Cells(1).Select
End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = False
End Sub
.
TextToColumns default parameters
DataType:=xlDelimited
ConsecutiveDelimiter:=False
Tab:=False
Semicolon:=False
Comma:=False
Space:=False
Other:=False
I have multiple sheets, each with data only in the first two columns:
Column A - ID
Column B - Name
I am trying to consolidate all these sheets into a master sheet. The format of the master sheet should be:
Column A - Sheet Name (From where the data was copied)
Column B - ID
Column C - Name
I have found a site that has code that does more or less this, however, after messing around with it for what feels like an eternity I just cannot get it to work.
The code works, in the sense that it copies the correct range and inputs the sheet name into column A, however, it doesn't stop by the "last row" of the range in the master sheet, it continues to populate the ENTIRE column A and the IF Statement that counts the rows is triggered and I get the msgbox pop up (see below in code). At this point, the code just ends and it does not get a chance to execute for the remaining sheets.
Link to site: https://www.rondebruin.nl/win/s3/win002.htm
Below is the code from the original site, with some minor adjustments for the range I will be using:
Sub CopySheetNameToColumn()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng = sh.Range("A:B")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.count > DestSh.Rows.count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "B")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Functions:
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Instead of
Set CopyRng = sh.Range("A:B")
try
Set CopyRng = sh.Range("A1", sh.Range("B" & Rows.Count).End(xlUp))
as the former covers every row of the worksheet, hence the message box and the name running down the whole sheet.
Something like:
Option Explicit
Sub CopySheetNameToColumn()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = GetLastRow(DestSh, 1)
With sh
Set CopyRng = sh.Range("A1:B" & GetLastRow(sh, 1))
End With
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
Else
CopyRng.Copy IIf(Last = 1, DestSh.Cells(1, "B"), DestSh.Cells(Last + 1, "B"))
End If
If Last = 1 Then
DestSh.Cells(Last, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
Else
DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
You can shorten this significantly... there are lots of posts about getting items on a master sheet, 4 from yesterday alone.
Take a look at this:
Dim lrSrc As Long, lrDst As Long, i As Long
For i = 1 To Sheets.Count
If Not Sheets(i).Name = "Destination" Then
lrSrc = Sheets(i).Cells(Sheets(i).Rows.Count, "A").End(xlUp).Row
lrDst = Sheets("Destination").Cells(Sheets("Destination").Rows.Count, "A").End(xlUp).Row
With Sheets(i)
.Range(.Cells(2, "A"), .Cells(lrSrc, "B")).Copy Sheets("Destination").Range(Sheets("Destination").Cells(lrDst + 1, "B"), Sheets("Destination").Cells(lrDst + 1 + lrSrc, "C")) 'Assumes headers in first row aren't being copied
Sheets("Destination").Range(Sheets("Destination").Cells(lrDst + 1, "A"), Sheets("Destination").Cells(lrDst + 1 + lrSrc, "A")).Value = Sheets(i).Name
End With
End If
Next i
Code now tested
Screenshot of what is happening here, for simplicity sake, I have changed the values to represent the columns that they rightfully belong in
I am working on a program where I need to copy and reorganize data from multiple worksheets into one master. One row per sheet. From columns G to R I will need to set up an if statement, so that if a value on the sheet is greater than 0 it will be copy/pasted to the next available column in it's row. For testing I have eliminated the if statement, so that I always get a result. The problem I am having is that on the first row of data the "B" column is being overwritten, subsequent rows work as expected. Any ideas as to why this could be happening?
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim LastR As Long
Dim LastC As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "Master" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Master").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "Master"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Master"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the last row with data on the DestSh
With ActiveSheet
LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
End With
With ActiveSheet
LastC = .Cells(LastR, .Columns.Count).End(xlToLeft).Column
End With
sh.Range("B2").Copy
DestSh.Cells(LastR + 1, "A").PasteSpecial xlPasteValues 'customer'
DestSh.Cells(LastR + 1, "B").Value = ("Glass") 'Product"
DestSh.Cells(LastR + 1, "C").Value = sh.Name 'Color Name
sh.Range("H32").Copy
DestSh.Cells(LastR + 1, "D").PasteSpecial xlPasteValues 'based on QTY'
DestSh.Cells(LastR + 1, "E").Value = ("Liters") 'based on Units'
DestSh.Cells(LastR + 1, "F").Value = ("Clear") 'Base'
sh.Range("F13").Copy
DestSh.Cells(LastR + 1, LastC + 1).PasteSpecial xlPasteValues 'THIS IS THE LINE GIVING ME TROUBLE'
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Try to replace ActiveSheet with DestSh, probably this is the reason for the problem:
'Find the last row with data on the DestSh
With DestSh
LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
End With
With DestSh
LastC = .Cells(LastR, .Columns.Count).End(xlToLeft).Column
End With
In your case, LastC = .Cells(LastR, .Columns.Count).End(xlToLeft).Column does not return the last column in the parent worksheet, but the last column in row LastR. Try this for the real last column:
LastC = LastRow(DestSh)
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
And this is worth reading - https://www.rondebruin.nl/win/s9/win005.htm
I found this code, it was only for one column to find all unique values, and filter them,copy/paste in filtered values named sheet.
But what I need to do, is filter two columns, and name it by the same principles, so I modified it.
Somehow on second value in first loop, it doesnt start loop in other loop.
Why does it give me blanks in second loop?
Sub datu_sagrupesana()
Dim x As Range, y As Range, rng As Range, last As Long, sht As Worksheet
Application.ScreenUpdating = False
'datu vieta
Set sht = ThisWorkbook.Worksheets("Test")
'apgabals
last = sht.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = sht.Range("A1:C" & last)
sht.Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True 'produkta filtrs
sht.Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("J1"), Unique:=True 'valodas filtrs
For Each y In Range([J2], Cells(Rows.Count, "J").End(xlUp))
For Each x In Range([H2], Cells(Rows.Count, "H").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=3, Criteria1:=y.Value
.AutoFilter Field:=1, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = y.Value & x.Value
ActiveSheet.Paste
End With
Next x
Next y
'nonemt filtru
sht.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
SOLVED by myself
Sub datu_sagrupesana()
Dim x As Long, y As Range, rng As Range, last As Long, sht As Worksheet
Application.ScreenUpdating = False
'datu vieta
Set sht = ThisWorkbook.Worksheets("Test")
'apgabals
last = sht.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = sht.Range("A1:C" & last)
sht.Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True 'produkta filtrs
sht.Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("I1"), Unique:=True 'valodas filtrs
pr = Application.WorksheetFunction.CountA(sht.Columns("H"))
va = Application.WorksheetFunction.CountA(sht.Columns("I"))
For j = 2 To va
For i = 2 To pr
valoda = sht.Cells(j, "I").Value
produkts = sht.Cells(i, "H").Value
'
'For Each y In Range("J2", Cells(Rows.Count, "J").End(xlUp))
'
'
'For Each x In Range("H2", Cells(Rows.Count, "H").End(xlUp))
'
With rng
.AutoFilter
.AutoFilter Field:=3, Criteria1:=valoda
.AutoFilter Field:=1, Criteria1:=produkts
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = valoda & produkts
ActiveSheet.Paste
End With
'
'Next x
'Next y
Next i
Next j
'nonemt filtru
sht.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub