I am trying to hide columns (Z,AA,AB,AC) if one of dependent cells are blank. i.e. if Range1 is blank entire column Z is hidden, Range2 is blank then entire column AA is hidden etc.
I know I could implement simple If Else/ .EntireColumn.Hidden statment but I was thinking to use code like below to make it neater. Any suggestions how to make it work ?
Sub(test)
Dim cell As Variant
Dim i As Integer
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("ReturnedHoldMail")
Set MyArray(1) = Sheets("test1").Range("Range1")
Set MyArray(2) = Sheets("test1").Range("Range2")
Set MyArray(3) = Sheets("test1").Range("Range3")
Set MyArray(4) = Sheets("test1").Range("range4")
For i = LBound(MyArray) To UBound(MyArray)
On Error Resume Next
For Each cell In MyArray(i)
If Len(cell.Value) < 1 Then
cell.EntireColumn.Hidden = True
Else
cell.EntireColumn.Hidden = False
End If
Next
Next
End With
End Sub
If you want the ranges that are hidden to be independent of the ranges being tested for emptiness, try the following:
Sub test()
Dim cell As Range
Dim i As Integer
Dim MyArray(1 To 4) As Range
Dim HideArray(1 To 4) As Range
Dim will_hide As Boolean
Set MyArray(1) = Sheets("test1").Range("Range1")
Set MyArray(2) = Sheets("test1").Range("Range2")
Set MyArray(3) = Sheets("test1").Range("Range3")
Set MyArray(4) = Sheets("test1").Range("Range4")
Set HideArray(1) = Sheets("test1").Range("Range5") ' or eg. Sheets("test2").Range("Z:Z")
Set HideArray(2) = Sheets("test1").Range("Range6")
Set HideArray(3) = Sheets("test1").Range("Range7")
Set HideArray(4) = Sheets("test1").Range("Range8")
For i = LBound(MyArray) To UBound(MyArray)
will_hide = True
For Each cell In MyArray(i)
If Len(cell.Value) > 0 Then
will_hide = False
End If
Next
HideArray(i).EntireColumn.Hidden = will_hide
Next
End Sub
Related
I have a range of cells which I'm scanning if the cell has a formular or not.
When it does, I want to save the column letters and row numbers i.e. E14, E18, F18, N18 (Reference) do a dictionary.
Once I've looped through my specific range, I want to select the cells saved in the dictionary to later on delete all cells with formulas in the selected cells.
I am stuck with the part to safe the cell reference to the dictionary.
The range in the example is just an example range.
Sub check_formula_empty()
Dim cell As Range
Dim i As Integer
Dim rng As Range
Set rng = Range("E13:N19")
For i = 1 To rng.Cells.Count
If rng.Cells(i).HasFormula = True And rng.Cells(i).Offset(-6, 0) = "A" Then
'save reference range to Dictionary
ElseIf rng.Cells(i).HasFormula = False And rng.Cells(i).Offset(-6, 0) = "F" Then
rng.Cells(i).Offset(-4, 0).Copy _
Destination:=rng.Cells(i)
End If
Next
'Here I want to run the "Select my saved range from the Dictionary" and run "delete formulas"
End Sub
You can us a collection for this purpose. You are mentioning a dictionary but for your purpose a key is not that important, you only need a list of items (collection supports both)
Sub check_formula_empty()
Dim cell As Range
Dim i As Integer
Dim rng As Range
Set rng = Range("E13:N19")
dim reflist as Collection
Set reflist = new Collection
For i = 1 To rng.Cells.Count
If rng.Cells(i).HasFormula = True And rng.Cells(i).Offset(-6, 0) = "A" Then
'save reference range to Dictionary
refList.Add rng.Cells(i)
ElseIf rng.Cells(i).HasFormula = False And rng.Cells(i).Offset(-6, 0) = "F" Then
rng.Cells(i).Offset(-4, 0).Copy _
Destination:=rng.Cells(i)
End If
Next
'Here I want to run the "Select my saved range from the Dictionary" and run "delete formulas"
Dim oneCell as Range
foreach oneCell in refList
oneCell.Value = vbEmpty
next
End Sub
As you can see we first add the complete cell to the collectdion (it is a referenced object) and later you can use it in the foreach loop to your liking with all its properties
So I was working on resolving the issue to run the VBA faster than looping 2-3x through each column.
My current issue, which I struggle to resolve is: that the defined range "nof" or "DBRW" keeps to increase, which when resolving my final code (delete or copy formula to the Union ranges), the whole Union ranges are selected and therefore formulars are overwritten for the full range, instead of looping from column to column and using the defined formula in that column, which is available in a fixed row (Cells(6, n)).
Option Explicit
Sub Test3()
Dim i As Integer
Dim n As Integer
Dim x As Integer
Dim DBRW As Range
Dim DBRWrange(1 To 32) As Range
Dim nof As Range
Dim nofRange(1 To 32) As Range
Dim rangef As Range
For n = 5 To 6
For i = 13 To 20
If Cells(i, n).HasFormula = True And Cells(7, n) = "A" Then
Set DBRWrange(i) = Cells(i, n)
If DBRW Is Nothing Then
Set DBRW = DBRWrange(i)
Else
Set DBRW = Union(DBRW, DBRWrange(i))
End If
ElseIf Cells(i, n).HasFormula = False And Cells(7, n) = "F" Then
Set nofRange(i) = Cells(i, n)
If nof Is Nothing Then
Set nof = nofRange(i)
Else
Set nof = Union(nof, nofRange(i))
End If
End If
Next i
Set rangef = Cells(6, n)
rangef.Copy nof
'Ranges in nof and DBRW are kept (incremented), is there a way to "refresh" the Union reference, to restart creating the range from after this step?
Next n
End Sub
ยดยดยด
so I have solved my issue and for future googlers, this might be helpful :)
Public Sub copy_paste_delete()
Dim i As Integer
Dim n As Integer
Dim DBRW As Range
Dim DBRWrange(1 To 150) As Range
Dim nof As Range
Dim nofRange(1 To 150) As Range
Dim rangef As Range
Application.ScreenUpdating = False
Worksheets("Tab1").Activate
Range("K29").Select
Set DBRW = Nothing
Set nof = Nothing
For n = 61 To 75
Set nof = Nothing
Set DBRW = Nothing
For i = 33 To 38
If Cells(i, n).HasFormula = True And Cells(6, n) = "F" Then
Set DBRWrange(i) = Cells(i, n)
If DBRW Is Nothing Then
Set DBRW = DBRWrange(i)
Else
Set DBRW = Union(DBRW, DBRWrange(i))
End If
ElseIf Cells(i, n).HasFormula = False And Cells(6, n) = "A" And Cells(7, n) = "Done" Then
Set nofRange(i) = Cells(i, n)
If nof Is Nothing Then
Set nof = nofRange(i)
Else
Set nof = Union(nof, nofRange(i))
End If
End If
Next i
Set rangef = Cells(19, n)
On Error Resume Next
rangef.Copy nof
Next n
DBRW.Select
'Do some stuff
Application.ScreenUpdating = True
End Sub
I'm new to vba and stackoverflow so please go easy on me!
I have two worksheets, call worksheet1 = GoldCopy and worksheet2 = A-OPS. They have about 10,000+ rows of data and should have some similar data. I want to compare the two sheets. Both of them have similar headers: Column A = filename and Column D = encryption code Column B = file path and Column F = in gold (or A-OPS depending on what ws you're looking at).
I want to be able to compare ws1 and ws2 and check for any discrepancies and highlight them as FALSE and the color red in column F. I currently want to check ws1 and go through each row, see if that filename and encryption code is in ws2, doesn't have to be the same row as ws1, but I want the filename and encryption code to be the same row (does that make sense?) WS2 could have this data in row 20 but ws1 would be on row 10 but since they have the same filename and encryption, then that's fine. If ws2 has the same filename AND same encryption code, then ws1 column F is TRUE. If ws2 does not have the same filename AND encryption in any of the rows, then ws1 column F is FALSE. I also want to do this same thing, except check ws2 against ws1.
This is the code I have so far, but it is taking forever because of these nested for loops. I have tried looking into something called "arrays" but I'm just very confused and would like something fast and efficient. The for loop is taking a really long time. Please let me know if I need to be more specific or explain more! Thanks so much
Sub Check
For Each s In Sheets
'NEW FILE SEARCH A-NAS OPS'
If s.Name = "A OPS" Then 'check if there is an A OPS file if so then proceed'
ACOL = Worksheets("A OPS").Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets("A OPS").Cells(1, ACOL + 1).Value = "In Gold Copy?"
'GoldCopy Check with A-NAS OPS'
Worksheets("GoldCopy").Activate
GROW = Worksheets("GoldCopy").Cells(Rows.Count, 1).End(xlUp).Row
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
AROW = Worksheets("A OPS").Cells(Rows.Count, 1).End(xlUp).Row
ACOL = Worksheets("A OPS").Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets("GoldCopy").Cells(1, GCOL + 1) = "Deployed in A OPS?"
For i = 2 To GROW
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
If InStr(Worksheets("GoldCopy").Cells(i, 3), "\sidata\") > 0 Then 'this is checking to see for a filepath from column B'
bln = False
For x = 2 To AROW
If Worksheets("GoldCopy").Cells(i, 1).Value = Worksheets("A OPS").Cells(x, 1) And Worksheets("GoldCopy").Cells(i, 4).Value = Worksheets("A OPS").Cells(x, 4).Value Then 'if the filename and encryption code in the same row in ws2 match ws1 then do next step'
bln = True
Worksheets("GoldCopy").Cells(i, GCOL) = bln
Worksheets("GoldCopy").Cells(i, GCOL).Interior.ColorIndex = 10
Exit For
Else
Worksheets("GoldCopy").Cells(i, GCOL) = bln
Worksheets("GoldCopy").Cells(i, GCOL).Interior.ColorIndex = 22
End If
Next x
End If
Next i
'A OPS check with GoldCopy'
Worksheets("A OPS").Activate
GROW = Worksheets("GoldCopy").Cells(Rows.Count, 1).End(xlUp).Row
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
AROW = Worksheets("A OPS").Cells(Rows.Count, 1).End(xlUp).Row
ACOL = Worksheets("A OPS").Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To AROW
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
If InStr(Worksheets("A OPS").Cells(i, 3), "\SIDATA\ops\common\") > 0 Or InStr(Worksheets("A OPS").Cells(i, 3), "\SIDATA\ops\j01\ecl\") > 0 Or InStr(Worksheets("A OPS").Cells(i, 3), "\SIDATA\ops\npp\ecl\") > 0 Then
bln = False
For x = 2 To GROW
If Worksheets("GoldCopy").Cells(x, 1).Value = Worksheets("A OPS").Cells(i, 1) And Worksheets("GoldCopy").Cells(x, 4).Value = Worksheets("A OPS").Cells(i, 4).Value Then
bln = True
Worksheets("A OPS").Cells(i, ACOL) = bln
Worksheets("A OPS").Cells(i, ACOL).Interior.ColorIndex = 10
Exit For
Else
Worksheets("A OPS").Cells(i, ACOL) = bln
Worksheets("A OPS").Cells(i, ACOL).Interior.ColorIndex = 22
End If
Next
End If
Next
Try to work through the below code. I dispersed comments throughout the code to indicate what the code does and why it does it. See if you can adapt it to your actual workbook. If you run into issues, write back and we'll try to work through them.
'Below code drives the analysis. Get a dictionary of
'unique keys from each sheet, then compare each sheet
'separately. You can pull your "response" into a separate
'function if you need the flexibility to change
Sub AnalyzeSheets()
Dim oGold As Object
Dim oAops As Object
Dim shtGold As Worksheet
Dim shtOps As Worksheet
Dim rngGold As Range
Dim rngOps As Range
Dim iterator As Range
Dim theKey As String
Set shtGold = Worksheets("GoldCopy")
Set shtOps = Worksheets("A Ops")
'Establish the data range for each sheet
'Mine is simply hardcoded
Set rngGold = shtGold.Range("A2:E8")
Set rngOps = shtOps.Range("A2:E7")
'Get a dictionary for each sheet. Pass in
'the range of the data
Set oGold = GetDictionary(rngGold)
Set oAops = GetDictionary(rngOps)
'Analyze each sheet separately
'Use Intersect to only iterate over the cells in the first column
For Each iterator In Intersect(rngGold, shtGold.Columns(1))
theKey = CreateKey(iterator.Value, iterator.Offset(, 3).Value)
If Not oAops.exists(theKey) Then
Respond iterator, False
Else
Respond iterator, True
End If
Next iterator
For Each iterator In Intersect(rngOps, shtOps.Columns(1))
theKey = CreateKey(iterator.Value, iterator.Offset(, 3).Value)
If Not oGold.exists(theKey) Then
'Call a response function. By putting the response
'into it's own function, you don't have to duplicate logic
'and it's easier to change
Respond iterator, False
Else
Respond iterator, True
End If
Next iterator
End Sub
Sub Respond(rng As Range, isFound As Boolean)
Dim sht As Worksheet
Set sht = rng.Parent
If isFound Then
sht.Range("F" & rng.Row).Value = "TRUE"
sht.Range("F" & rng.Row).Interior.ColorIndex = 10
Else
sht.Range("F" & rng.Row).Value = "FALSE"
sht.Range("F" & rng.Row).Interior.ColorIndex = 22
End If
End Sub
'Use this function to generate a unique key for each row
'Since 2 columns form a unique key, I'm simply taking each
'value and joining with a hypen. By pulling this logic into
'it's own function, you have more flexibility for future changes.
Function CreateKey(s1 As String, s2 As String) As String
Dim delimiter As String
delimiter = "-"
CreateKey = s1 & delimiter & s2
End Function
'Use below to create a dictionary holding unique key values
'You can update the code within to identify which cells
'are used to generate a key
Function GetDictionary(inputRange As Range) As Object
Dim oDict As Object
Dim sht As Worksheet
Dim cel As Range
Dim theKey As String
Set sht = inputRange.Parent
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In Intersect(inputRange, sht.Columns(1))
'(A) - Filename (D) - Encryption
theKey = CreateKey(sht.Range("A" & cel.Row).Value, _
sht.Range("D" & cel.Row).Value)
'If the key hasn't been added, add it (don't need value)
If Not oDict.exists(theKey) Then
oDict.Add theKey, ""
End If
Next cel
Set GetDictionary = oDict
End Function
I need to do a vba code to compare texts in two columns and highlight matched texts in the second column. I started on the code and below is what I got so far. It works fine on the first row, how to modify the code to apply this for the entire table not just the first row. I'm new to VBA and any help would be great.
Sub Test1()
Dim strString$, x&
Dim rngCell As Range
strString = Range("G2").Value
Application.ScreenUpdating = False
For Each rngCell In Range("S2", Range("S" & Rows.Count).End(xlUp))
With rngCell
.Font.ColorIndex = 1
For x = 1 To Len(.Text) - Len(strString) Step 1
If Mid(.Text, x, Len(strString)) = strString Then .Characters(x, Len(strString)).Font.ColorIndex = 5
Next x
End With
Next rngCell
Application.ScreenUpdating = True
End Sub
If your code works correctly on the first row (I haven't tested it, so will just trust that you are correct), then the following is, I think, what you want to change:
Sub Test1()
Dim strString$, x&
Dim rngCell As Range
Application.ScreenUpdating = False
For Each rngCell In Range("S2", Range("S" & Rows.Count).End(xlUp))
With rngCell
.Font.ColorIndex = 1
strString = Cells(rngCell.Row, "G").Value
For x = 1 To Len(.Text) - Len(strString) Step 1
If Mid(.Text, x, Len(strString)) = strString Then .Characters(x, Len(strString)).Font.ColorIndex = 5
Next x
End With
Next rngCell
Application.ScreenUpdating = True
End Sub
i.e. move the calculation of strString inside the loop and base it on the value in column G of the row being processed.
I just gave someone this answer to a very similar question...
Sub ColorMatchingString()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim strTest As Collection: Set strTest = New Collection
Dim udRange As Range: Set udRange = ws.Range("AC2:AC311") 'Define Search Ranges
Dim myCell, myMatch, myString, i
Dim temp() As String, tempLength As Integer, stringLength As Integer
Dim startLength as Integer
For Each myMatch In udRange 'Build the collection with Search Range Values
strTest.Add myMatch.Value
Next myMatch
For Each myCell In ws.Range("A2:AB1125") 'Loop through each cell in range
temp() = Split(myCell.Text, ", ") 'define our temp array as "," delimited
startLength = 0
stringLength = 0
For i = 0 To UBound(temp) 'Loop through each item in temp array
tempLength = Len(temp(i))
stringLength = stringLength + tempLength + 2
For Each myString In strTest
'Below compares the temp array value to the collection value. If matched, color red.
If StrComp(temp(i), myString, vbTextCompare) = 0 Then
startLength = stringLength - tempLength - 1
myCell.Characters(startLength, tempLength).Font.Color = vbRed
End If
Next myString
Next i
Erase temp 'Always clear your array when it's defined in a loop
Next myCell
End Sub
I have a column range of about 500 rows. Most of those cells are stored as text. I populate a listbox on a userform with the values from that range. When a user selects one of those values from the listbox an event will find the value on the same row from another column using Index and Match and display it in a label on the userform. I get an error when selecting one of the few cells in the listbox that are not stored as text in the range because there is a leading space. I am assuming that the populated listbox automatically removes leading spaces from any cells in the range. Therefore, when it tries to find value 12345 from the listbox, for example, in the range it can't find it because the range contains (space)12345. I have tried:
Public Sub UserForm_Initialize()
Dim arr() As Variant
Dim rNum As Range
Const sNum As String = "Number"
Me.EnableEvents = False
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pReport
If .AutoFilterMode = True Then .ShowAllData
.Cells.Rows.Hidden = False
.Cells.Columns.Hidden = False
End With
Set wf = Application.WorksheetFunction
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
End With
-- HERE is where I tried all my implementations without success
arr = wf.Transpose(pReport.Range(rNum.address).Value)
Call BubbleSort(arr)
frmIssues.lstIssues1.List = arr
lstIssues1.ListStyle = 1
lstIssues2.ListStyle = 1
lstIssues1.MultiSelect = 2
lstIssues2.MultiSelect = 2
txtFocus.SetFocus
Me.EnableEvents = True
End Sub
Private Sub lstIssues1_Change()
Dim rNum As Range
Dim rTitle As Range
Dim strResult As String
Dim intIndex As Integer
Dim intCount As Integer
Const sNum As String = "Number"
Const sTitle As String = "Title"
If EnableEvents = False Then Exit Sub
With lstIssues1
For intIndex = 0 To .ListCount - 1
If .Selected(intIndex) Then intCount = intCount + 1
Next
End With
If intCount = 1 Then
Set wf = Application.WorksheetFunction
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
Set rTitle = .ListColumns(.ListColumns(sTitle).Range.column).DataBodyRange
End With
With pReport
strResult = wf.Index(.Range(rTitle.address), wf.Match(lstIssues1.List(lstIssues1.ListIndex), .Range(rNum.address), 0))
End With
lblDescription.Caption = wf.Trim(strResult)
txtFocus.SetFocus
Else
lblDescription.Caption = ""
txtFocus.SetFocus
Exit Sub
End If
Me.EnableEvents = False
For i = 0 To lstIssues2.ListCount - 1
If lstIssues2.Selected(i) = True Then lstIssues2.Selected(i) = False
Next
Me.EnableEvents = True
End Sub
and numerous variations of it (Clean, CStr, .Text, etc.) and nothing works. Truly, I have no clue how to fix this and any help whatsoever is much appreciated. Thank you!
Clarification
1) This Excel file is generated from the Web.
2) A Macro turns the Worksheet into a table
3) Left(Range("D362"),1) returns 1 (The number, say, is 12345)
4) Before the error occurs Range("D362") returns (space)12345
5) After the error occurs Range("D362") returns (space)12345
I have just tested this and it works in removing the space at the begining of a string. Sadly it isnt a single line as I (and likely you) would have prefered
Sub test()
Dim CellValue As String
Dim lngNumberOfCharacters As Long
CellValue = ActiveCell.Value
CellValueCheck = Left(CellValue, 1)
If CellValueCheck = " " Then
lngNumberOfCharacters = Len(CellValue) - 1
CellValue = Right(CellValue, lngNumberOfCharacters)
ActiveCell.Value = CellValue
End If
End Sub
Let me know if you need anything confirmed
I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True