Why isn't my data populated when i used VBA to create worksheets beforehand? - excel

Previously, when I created the worksheets index 1,2,3 in excel,
it can be sorted into like this in index 1 2 and 3 respectively
But now if i stop creating worksheets in excel but through VBA instead, the data cant be populated and it leaves index 1,2 and 3 empty.
This is the code that I used for populating the data but with the addition of add.sheets. The add.sheets here are for creating index1,2,3 worksheets but they doesn't trigger the program to continue to populate the data even though these worksheets exists when I program them in VBA.
Sub UpdateVal()
Static count As Long
Dim iRow As Long
Dim aRow As Long
Dim a As Long
Dim b As Long
Dim selectRange As Range
Dim lastline As Integer
Dim sheetname As String
Dim indexrowcount As Integer
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Result")
Set site_ai = Sheets.Add(after:=Sheets(Worksheets.count))
site_ai.Name = "Index1"
Set site_bi = Sheets.Add(after:=Sheets(Worksheets.count))
site_bi.Name = "Index2"
Set site_ci = Sheets.Add(after:=Sheets(Worksheets.count))
site_ci.Name = "Index3"**
'^additional codes sheets.Add added here for creating worksheets namely index1,2,3
j = 2
iRow = 1
lastline = ws.UsedRange.Rows.count
While iRow < lastline + 1
a = iRow + 1
b = iRow + 17 ' Max Group Size with Same name in F to H column
count = 1
If ws.Cells(iRow, "F").Value = "Martin1" Then
sheetname = "Index1"
ElseIf ws.Cells(iRow, "F").Value = "John1" Then
sheetname = "Index2"
Else
sheetname = "Index3"
End If
For aRow = a To b
If ws.Cells(iRow, "F") = ws.Cells(aRow, "F") And ws.Cells(iRow, "G") = ws.Cells(aRow, "G") And ws.Cells(iRow, "H") = ws.Cells(aRow, "H") Then
count = count + 1
Else
Set selectRange = Range("A" & iRow & ":J" & aRow - 1)
selectRange.Copy
indexrowcount = Sheets(sheetname).UsedRange.Rows.count
Sheets(sheetname).Range("A" & indexrowcount).PasteSpecial xlPasteAll
iRow = iRow + count
Exit For
End If
Next aRow
Wend
End Sub
what am I missing here and how should i solve it?

Your code is too confusing. If your example data is accurate, I don't understand why you need to check all three columns. You can accomplish what you are trying to do, by just using column F. If your data is already sorted as shown, then I would loop through column F testing for duplicates until no match. I would then add a worksheet and name it using the start cells' value. Then copy the rows from the start cell to the current rwNbr - 1 and paste to the new worksheet. Reset the start cell for the next group and loop.
Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long
Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable
Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
Application.DisplayAlerts = False
For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop
If ws.Cells(rwNbr, 6).Value <> sCel.Value Then 'loop until the value changes
wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count)).Name = sCel.Value 'Add sheet and name based on the first cell of group
ws.Range(sCel, ws.Cells(rwNbr - 1, 6)).EntireRow.Copy Destination:=ActiveSheet.Range("A1") 'select group of consecutive duplicates
Set sCel = ws.Cells(rwNbr, 6) 'reset start cell to test for the next group of consecutive duplicates
End If
Next rwNbr
Application.DisplayAlerts = True
End Sub

Related

Loop through and copy paste values without repetition if conditions are met

Im trying to create a table that pulls data from my raw data if certain conditions are met. The code I currently have does not seem to be working.
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long
Dim tableA As ListObject
Set tableA = Worksheets(Sheet7).ListObject(Preventable)
Set datasheet = Worksheets(Sheet7)
Set datasheet2 = Worksheets("Data")
With datasheet2
nr = Cells(Rows.Count, 1).End(x1up).Row
For r = 1 To nr
If Cells(r, 17) = "Y" Then
Cells(r, 16).Copy Destination:=Sheets("Sheet7").Range("B4")
End If
Next
End With
End Sub
Basically I have several worksheets and need to pull data from one of them to add to this table in another worksheet. My condition is if the Column in the raw data worksheet contains "Y", then pull cell values into the table of the other worksheet. An image below is an example of the data I want to copy and paste over:
As you can see, they are string values separated by "," and can contain duplicates.
I only want to add just the unique entries into the new table; with no repetition of cells. Anyway I could modify this code to suit those conditions?
You could try something like this:
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long, i As Long, nr As Long
Dim tableStartingRow As Long, currenttableitem As Long
Dim stringvalues As Variant
Dim stringseparator As String
Dim valueexists As Boolean
tableStartingRow = 4
stringseparator = ","
Set datasheet = Worksheets("Sheet7")
Set datasheet2 = Worksheets("Data")
With datasheet
currenttableitem = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
With datasheet2
nr = .Cells(.Rows.Count, 16).End(xlUp).Row
For r = 1 To nr
If .Cells(r, 17) = "Y" Then
If InStr(.Cells(r, 16), stringseparator) > 0 Then 'If value contains comma
stringvalues = Split(.Cells(r, 16), stringseparator)
For i = LBound(stringvalues) To UBound(stringvalues)
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = Trim(stringvalues(i)) Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = Trim(stringvalues(i))
End If
Next i
Else
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = .Cells(r, 16).Value Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = .Cells(r, 16).Value
End If
End If
End If
Next
End With
End Sub
This code will check each value of the cells and will split the contents by ",". Then compare with the content of the table to see if this value is already in there. In case it is not, it will be added, otherwise omitted.
Also, I notice the use of the Cells inside of a With statement. That was making a reference to the active worksheet. To make reference to the item in the With statement, you need to use .Cells
I hope this will help.

Moving rows from one worksheet to specific worksheets based on keywords found in string in a specific column in master worksheet

I have an Excel worksheet called "Main" which includes a set amount of columns, one of which contains a listing of different codes (CVE's) regarding patches that need to be installed on worksheets based on criteria from the internet.
The codes to search for are not in a set format, other than being in strings containing the code.
I manually created a number of worksheets based on keywords in these strings, that will eventually, contain all the lines from the master sheet, but only those defined by the name of the keyword I want.
For example, I have a worksheet named "Microsoft" that should contain all the rows from the master sheet that refer to Microsoft CVE's, based on a search of the string and finding the word "Microsoft". Same for Adobe and so on.
I created a script to copy the rows, as well as create a new Index sheet that lists the amount of rows found for each keyword that have been copied from the master sheet to the relevant sheet.
And this is where I get lost.
I have 18 worksheets which are also keywords. I can define a single keyword and then copy everything over from the main worksheet for one keyword.
I need a loop (probably a loop within a loop) that reads the worksheet names as defined in the Index, searches for all the relevant rows that contain a CVE regarding that keyword, and then copy the row over to the relevant worksheet that I created into the relevant row on that worksheet.
For example, if I have copied two rows, the next one should be written to the next row and so on, until I have looped through all the worksheet (keyword) names and have reached the empty row after the last name in the Index sheet.
My code, set for only one keyword for a limited run to test works.
I need to loop through all the keywords and copy all the data.
In the end, I want to copy the relevant row from the master worksheet (Main) to the relevant worksheet (based on keyword worksheet name in the Index worksheet), and delete the row after it was copied from the master worksheet.
I should end up with all the data split into the relevant worksheets and an empty (except for headers) master worksheet.
This is what I have so far (from various examples and my own stuff).
Public WSNames() As String
Public WSNum() As Long
Public I As Long
Public ShtCount As Long
Sub MoveBasedOnValue()
Dim CVETitle As String
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
Dim D As Long
Dim CountCop As Long
A = Worksheets("Main").UsedRange.Rows.Count
A = A + 1
'Create an index of the worksheet names to work with for moving the data and counting the lines in the WS
ReadWSNames
B = Worksheets(WSNames(2)).UsedRange.Rows.Count
B = B + 1 'Place under the last row for start
'Range to read and scan from
Set xRg = Worksheets("Main").Range("E5:E" & A)
On Error Resume Next
Application.ScreenUpdating = False
'For C = 1 To xRg.Count
For C = 1 To 5
'Read in the string to search from the Main WS
CVETitle = CStr(xRg(C).Value)
'Find if the word we want exists in the string
If InStr(1, CVETitle, WSNames(2)) > 0 Then
xRg(C).EntireRow.Copy Destination:=Worksheets(WSNames(2)).Range("A" & B + 1)
CountCop = Worksheets("Index").Range("B3").Value
CountCop = CountCop + 1
Worksheets("Index").Range("B3").Value = CountCop
'xRg(C).EntireRow.Delete
'If CStr(xRg(C).Value) = WSNames(2) Then
'C = C - 1
'End If
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Sub ReadWSNames()
ReDim WSNames(1 To ActiveWorkbook.Sheets.Count)
ReDim WSNum(1 To ActiveWorkbook.Sheets.Count)
Dim MyIndex As Worksheet
ShtCount = Sheets.Count
'Read sheetnames and number of lines in each WS into arrays and clear the sheets other than the main one
If Not IndexExists("Index") Then
For I = 1 To ShtCount
WSNames(I) = Sheets(I).Name
If WSNames(I) <> "Main" Then ActiveWorkbook.Worksheets(WSNames(I)).Range("5:10000").EntireRow.Delete
WSNum(I) = Worksheets(WSNames(I)).UsedRange.Rows.Count
WSNum(I) = WSNum(I) - 3
Next I
'Add an index worksheet before the main worksheet and make sure one doesn't exist
Worksheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "Index" 'Give new Ws a name
Application.DefaultSheetDirection = xlLTR 'Make direction suited to English
'Write headers and set parameters
Range("A1").Value = "WS Names"
Range("B1").Value = "Count"
With Range("A1:B1")
.Font.Size = 14
.Font.Bold = True
.Font.Color = vbBlue
End With
Columns("A:B").AutoFit
Columns("B:B").HorizontalAlignment = xlCenter
'Write data from arrays into Index WS
ActiveCell.Offset(1, 0).Select
For I = 1 To ShtCount 'Write values to Index WS
ActiveCell.Value = WSNames(I) 'Write Worksheet name
ActiveCell.Offset(0, 1) = WSNum(I) 'Write number of rows already existing in Ws
ActiveCell.Offset(1, 0).Select 'Move one cell down
Next I
Worksheets("Index").Activate 'Make Index the active ws
Range("A2").Select 'Select first cell to read data from
I = 1
X = 2
Do While Not IsEmpty(Range("A" & X)) 'Read values back into array to make sure i's all there
WSNames(I) = ActiveCell.Value
WSNum(I) = ActiveCell.Offset(0, 1).Value
ActiveCell.Offset(1, 0).Select 'Move one cell down
I = I + 1
X = X + 1
Loop
Worksheets("Main").Activate 'Make Main the active ws
Else 'If Index exists, simply read the data into the arrays
Worksheets("Index").Activate 'Make Index the active ws
Range("A2").Select 'Select first cell to read data from
I = 1
X = 2
Do While Not IsEmpty(Range("A" & X)) 'Read values back into array to make sure i's all there
WSNames(I) = ActiveCell.Value
WSNum(I) = ActiveCell.Offset(0, 1).Value
ActiveCell.Offset(1, 0).Select 'Move one cell down
I = I + 1
X = X + 1
Loop
Worksheets("Main").Activate 'Make Main the active ws
Exit Sub
End If
End Sub
Function IndexExists(sSheet As String) As Boolean
On Error Resume Next
sheetExist = (ActiveWorkbook.Sheets(sSheet).Index > 0)
End Function
Because the CVE strings are not the same, it is not possible to sort them, so there can be a CVE for Microsoft in one row and then a few rows of other CVEs, and the Microsoft again and so on.
I tried to post picture examples of the Index worksheet, the worksheet names, and an example of the data in the lines, but I don't have enough reputation.
So, a few examples (out of over 7,000 lines) of the string data is that is searched for the keyword (column E):
*[MS20-DEC] Microsoft Windows Cloud Files Mini Filter Driver Elevation of Privilege Vulnerability - CVE-2020-17134 [APSB16-04]
*Adobe Flash Player <20.0.0.306 Remote Code Execution Vulnerability - CVE-2016-0964 [MS21-JUN] *
*Microsoft Kerberos AppContainer Security Feature Bypass Vulnerability - CVE-2021-31962
*McAfee Agent <5.6.6 Local Privilege Escalation Vulnerability - CVE-2020-7311
*7-Zip <18.00 and p7zip Multiple Memory Corruption Vulnerabilities - CVE-2018-5996
Scan the sheets for a word and then scan down the strings in sheet Main for that word. Scan up the sheet to delete rows.
update - muliple words per sheet
Option Explicit
Sub SearchWords()
Const COL_TEXT = "E"
Const ROW_TEXT = 5 ' first line of text
Dim wb As Workbook
Dim ws As Worksheet, wsMain As Worksheet, wsIndex As Worksheet
Dim arData(), arDelete() As Boolean
Dim lastrow As Long, i As Long, n As Long, r As Long
Dim word As String, txt As String
Dim t0 As Single: t0 = Timer
Dim w
' create index if not exists
CreateIndex
Set wb = ActiveWorkbook
With wb
Set wsMain = .Sheets("Main")
Set wsIndex = .Sheets("Index")
End With
' copy strings into array for speed
With wsMain
lastrow = .Cells(.Rows.Count, COL_TEXT).End(xlUp).Row
If lastrow < ROW_TEXT Then
MsgBox "No text found in column " & COL_TEXT, vbCritical
Exit Sub
End If
arData = .Cells(1, COL_TEXT).Resize(lastrow).Value2
ReDim arDelete(1 To lastrow)
End With
' scan main for each keyword in index
i = 2 ' index row
Application.ScreenUpdating = False
For Each ws In wb.Sheets
If ws.Name <> "Index" And ws.Name <> "Main" Then
'word = ws.Name
lastrow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
For Each w In Split(ws.Name, "+")
word = Trim(w)
For r = ROW_TEXT To UBound(arData)
txt = arData(r, 1)
If InStr(1, txt, word, vbTextCompare) > 0 Then
lastrow = lastrow + 1
wsMain.Rows(r).Copy ws.Cells(lastrow, 1)
arDelete(r) = True
n = n + 1
End If
Next
Next
' update index
wsIndex.Cells(i, 1) = ws.Name
wsIndex.Cells(i, 2) = lastrow - 1
i = i + 1
End If
Next
' delete or highlight rows
' scan upwards
For r = UBound(arDelete) To ROW_TEXT Step -1
If arDelete(r) = True Then
wsMain.Cells(r, COL_TEXT).Interior.Color = vbYellow
'wsMain.Rows(r).Delete 'uncomment to delete
End If
Next
Application.ScreenUpdating = True
MsgBox n & " lines copied", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
Sub CreateIndex()
Dim ws As Worksheet, bHasIndex As Boolean
For Each ws In Sheets
If ws.Name = "Index" Then bHasIndex = True
Next
' create index
If Not bHasIndex Then
Worksheets.Add(before:=Sheets(1)).Name = "Index"
End If
' format index
With Sheets("Index")
.Cells.Clear
With .Range("A1:B1")
.Value2 = Array("WS Names", "Count")
.Font.Size = 14
.Font.Bold = True
.Font.Color = vbBlue
End With
.Columns("A:B").AutoFit
.Columns("B:B").HorizontalAlignment = xlCenter
End With
End Sub

How do i copy and paste data to worksheets that i created in VBA using for loop?

Im trying to copy and paste my data and assign them into different worksheets.For example, if column F is martin 1, the entire row that has martin1 will be paste to worksheets("Index1"). Same thing for Charlie 1 and it will be paste to worksheets("Index2"). However, I faced with a object defined error here as shown in my code below. Any ideas how to solve it?
Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long
Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable
Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
Dim i As Integer
Dim site_i As Worksheet
For i = 1 To 3
Set site_i = Sheets.Add(after:=Sheets(Worksheets.count))
site_i.Name = "Index" & CStr(i)
Next i
Application.DisplayAlerts = False
For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop
If ws.Cells(rwNbr, 6).Value = "Martin1" Then
ws.Range(sCel, ws.Cells(rwNbr, 6)).EntireRow.Copy Destination:=Sheets("Index1").Range("A1")
ElseIf ws.Cells(rwNbr, 6).Value = "Charlie1" Then
ws.Range(sCel, ws.Cells(rwNbr - ws.UsedRange.Rows.count, 6)).EntireRow.CopyDestination:=Sheets("Index2").Range("A1") '<----application defined or object defined error here
End If
Next rwNbr
Application.DisplayAlerts = True
End Sub
This is the link to my worksheet. https://www.dropbox.com/home?preview=Sample+-+Copy.xlsm
The final output should look something like this...
If your raw data does not have a header row then I would use a loop to gather up your target cells and copy them accordingly.
You will need to update your 3 target values inside Arr to Charlie1, Martin1, etc.
Macro Steps
Loop through each name in Arr
Loop through each row in Sheet1
Add target row to a Union (collection of cells)
Copy the Union to the target sheet where target Sheet Index # = Arr position + 1
Sub Filt()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet
Dim Arr: Arr = Array("Value1", "Value2", "Value3")
Dim x As Long, Target As Long, i As Long
Dim CopyMe As Range
'Create 3 Sheets, move them to the end, rename
For x = 1 To 3
Set cs = ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
cs.Name = "Index" & x
Next x
lr = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
'Loop through each name in array
For Target = LBound(Arr) To UBound(Arr)
'Loop through each row
For i = 1 To lr
'Create Union of target rows
If ws.Range("F" & i) = Arr(Target) Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, ws.Range("F" & i))
Else
Set CopyMe = ws.Range("F" & i)
End If
End If
Next i
'Copy the Union to Target Sheet
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Index" & Target + 1).Range("A1")
Set CopyMe = Nothing
End If
Next Target
End Sub
Tested and working as expected on my end, however....
If you had headers this would be much easier with a copy/paste. If you run the same macro on same book twice this will break for many reasons such as having duplicated sheet names, breaking the relationship between Sheet Index # = Arr Position + 1, etc...

Print value blocks into new worksheets?

I have a worksheet that I need to split out into new ones by column C values. There are 8 values, so I'll need 8 worksheets. Each value has about 2-5000 corresponding rows, so this script isn't ideal because it prints row-by-row.
Sub SplitData()
Const iCol = 3 ' names in second column (B)
Const sRow = 2 ' data start in row 2
Dim wshSource As Worksheet
Dim wshTarget As Worksheet
Dim i As Long
Dim lRow As Long
Dim lngTargetRow As Long
Application.ScreenUpdating = False
Set wshSource = Sheets(1)
lRow = wshSource.Cells(wshSource.Rows.Count, iCol).End(xlUp).Row
For i = sRow To lRow
If wshSource.Cells(i, iCol).Value <> wshSource.Cells(i - 1, iCol).Value Then
Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wshTarget.Name = wshSource.Cells(i, iCol).Value
wshSource.Rows(sRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
lngTargetRow = 2
End If
wshSource.Rows(i).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
lngTargetRow = lngTargetRow + 1
Next i
Application.ScreenUpdating = True
End Sub
How would I change this up to print each value block (column C) to each worksheet instead of every row (i) individually? Would I need to implement auto-filtering by column C values and do a loop that way?
Try this out, as you well pointed, filtering would be the fastest way here:
Option Explicit
Sub Test()
Dim uniqueValues As Object
Set uniqueValues = CreateObject("Scripting.Dictionary")
Dim i As Long
With ThisWorkbook.Sheets("MainSheet") 'change MainSheet to the name of the sheet containing the data
'First let's store the unique values inside a dictionary
For i = 2 To .UsedRange.Rows.Count 'this will loop till the last used row
If Not uniqueValues.Exists(.Cells(i, 3).Value) Then uniqueValues.Add .Cells(i, 3).Value, 1
Next i
'Now let's loop through the unique values
Dim Key As Variant
For Each Key In uniqueValues.Keys
.UsedRange.AutoFilter Field:=3, Criteria1:=Key 'Filter column C by the value in the key
ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'add a new sheet
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Key 'change the name of the new sheet to the key's
.UsedRange.SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Sheets(Key).Range("A1") 'copy the visible range after the filter to the new sheet
Next Key
End With
End Sub

Excel 2013 Overflow due to lack of VBA optimization

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

Resources