Styjun

I have a table that I need to do the following with:

1. Get the range of the fk_keyword column


2. Loop through the range and identify only unique values


3. Loop through the unique values and create sheets with the name of the unique values


4. Loop through the original range (fk_keyword) and copy the entire row to the sheet with the matching name

For example: If the value found in fk_keyword matches the name of a sheet, then for all the cells that meet the same criteria, their entire row must be copied to that sheet.

I found a few similar questions, however, they all seem to be slightly different to my query, in that I am having different issues..

The closest match to my question I found is here:

VBA- search sheet name from range.. then copy from range sheet, paste transpose into that sheetname

Even though I found this, I am not using the code in this example.

Instead, I have received the help up to this point from these links:

Copy Entire Row to New Sheet:

https://www.extendoffice.com/documents/excel/3723-excel-move-row-to-another-sheet-based-on-cell-value.html

Create Sheets from Excel Cell Value:

Auto create Excel sheets from Array values

Remove Duplicates from Array:

https://wellsr.com/vba/2017/excel/vba-remove-duplicates-from-array/

So here is the code I have at the moment:

Functions:

move_Data_To_Sheet

Function move_Data_To_Sheet(myArray As Variant)

 'Dim variables
 Dim xRg As Range, xCell
 Dim I As Long, J, K, Counter
 Dim tmpltWkbk As Workbook
 Dim ws1 As Worksheet

 'Set variables
 Set xRg = find_Header("fk_keyword")
 Set tmpltWkbk = Workbooks("New DB.xlsm")
 Set ws1 = tmpltWkbk.Sheets("TableSheet")

 'Get the row count of the primary sheet
 I = ws1.UsedRange.Rows.Count

 Counter = 0

 'loop through each element in my array
 For Each c In myArray

 'Check that that element is not empty
 If c <> "" Then

 'Add a new sheet after the active sheet
 Sheets.Add After:=ActiveSheet

 'Name the new sheet the same as the current element name in the array
 ActiveSheet.Name = c

 'Get the row count of the new sheet
 J = Worksheets(c).UsedRange.Rows.Count

 'Check if the value is 1
 If J = 1 Then

 'Check if the value is 0
 If Application.WorksheetFunction.CountA(Worksheets(c).UsedRange) = 0 Then

 'J is actually empty
 J = 0

 End If

 End If

 'Loop through the specific range (fk_keyword) on the primary sheet
 For K = 1 To xRg.Count

 'Check if the element matches the current element in the first array
 If CStr(xRg(K).Value) = c Then

 'Copy the entire row from the primary sheet to the newly added sheet
 xRg(K).EntireRow.Copy Destination:=Worksheets(c).Range("A" & J + 1)

 'Delete the row from the primary sheet
 xRg(K).EntireRow.Delete

 'Increment J
 J = J + 1

 'Increment the counter
 Counter = Counter + 1

 End If

 'Next element in the array
 Next

 End If

 'Next element in the array
 Next c

End Function

Below is the issue I am experiencing.

When the data is copied to the new sheets based on the Cell value (KW ID), it seems to only copy some of the data and not all of it.

For Example, in the image below are the totals for the numeric values found under the fk_keyword column in my sheet. These numeric values are KW ID's and the totals are how many times they appear in the fk_keyword column.

Now when I copy the data to the new sheets, instead of having all the data copied, it will copy something like this:

• For KW ID 5: 11 Rows


• For KW ID 9: 15 Rows


• For KW ID 10: 13 Rows

And so on. But not a single KW ID, with all its rows were copied and I cannot understand why.