Moving data from one sheet to multiple sheets - vba

[Eitel13]

Hi All,

I have some code that creates worksheets based on a cell value in a column and then I have the below code which will scan the same column and move the entire row of that sheet to the matching sheet name.

Sub CopyRowData()

'Declare variables
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim shSource As Worksheet
Dim shTarget1 As Worksheet
Dim shTarget2 As Worksheet
Dim shTarget3 As Worksheet
Dim shTarget4 As Worksheet
Dim shTarget5 As Worksheet
Dim shTarget6 As Worksheet

'Assign string values to variables
Set shSource = ThisWorkbook.Sheets("1")
Set shTarget1 = ThisWorkbook.Sheets("2")
Set shTarget2 = ThisWorkbook.Sheets("3")
Set shTarget3 = ThisWorkbook.Sheets("4")
Set shTarget4 = ThisWorkbook.Sheets("5")
Set shTarget5 = ThisWorkbook.Sheets("6")
Set shTarget6 = ThisWorkbook.Sheets("7")

'Locate the rows to be checked
'2
If shTarget1.Cells(3, 6).Value = "" Then
a = 3
Else
a = shTarget1.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If

'3
If shTarget2.Cells(3, 6).Value = "" Then
b = 3
Else
b = shTarget2.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If

'4
If shTarget3.Cells(3, 6).Value = "" Then
c = 3
Else
c = shTarget3.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If

'5
If shTarget4.Cells(3, 6).Value = "" Then
d = 3
Else
d = shTarget4.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If

'6
If shTarget5.Cells(3, 6).Value = "" Then
e = 3
Else
e = shTarget5.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If

'7
If shTarget6.Cells(3, 6).Value = "" Then
f = 3
Else
f = shTarget6.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If


i = 3

'Do while that will read the data of the cells in the 5th column and if it is match for the string variables, it will move the entire row to the worksheet of the same name
Do While i <= 200
    '2
    If Cells(i, 6).Value = "2" Then
    shSource.Rows(i).Copy
    shTarget1.Cells(a, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    a = a + 1
    GoTo Line1
    
    '3
    ElseIf Cells(i, 6).Value = "3" Then
    shSource.Rows(i).Copy
    shTarget2.Cells(b, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    b = b + 1
    GoTo Line1
    End If
    
    '4
    If Cells(i, 6).Value = "4" Then
    shSource.Rows(i).Copy
    shTarget3.Cells(c, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    c = c + 1
    GoTo Line1
    
    '5
    ElseIf Cells(i, 6).Value = "5" Then
    shSource.Rows(i).Copy
    shTarget4.Cells(d, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    d = d + 1
    GoTo Line1
    End If
    
    '6
    If Cells(i, 6).Value = "6" Then
    shSource.Rows(i).Copy
    shTarget5.Cells(e, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    e = e + 1
    GoTo Line1
    
    '7
    ElseIf Cells(i, 6).Value = "7" Then
    shSource.Rows(i).Copy
    shTarget6.Cells(f, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    f = f + 1
    GoTo Line1
    End If
    
    i = i + 1


Line1:     Loop

    Set mysheet = ActiveSheet
    Dim wrksht As Worksheet
    For Each wrksht In Worksheets
       
    wrksht.Select
    Cells.EntireColumn.AutoFit
       
    Next wrksht
    mysheet.Select

End Sub

I get the "Run Time Error 9, Subscript out of range". The reason I get this error is because the sheet does not exist.
So for example, when the sheets are being created based on their cell values and in the cell there's no actual number 4, then a sheet with the name "4" will obviously not be created. So the above code when executed throws out this error.

Ideally I wanted to code it in a way that didn't require hard coded string variables to do the check, but I simply don't know how to create that dynamic piece of code. So this is what I have at the moment and I am hoping someone can either help clean up the code to not have hard coded variables (1,2,3,4...) and perhaps just do a check first if the sheet exists then look for the sheet name in the column OR do the same thing but just input some kind of if statement to determine if the sheet exists before it bombs out.

I'm thinking of something like:

If (sheet.name("4") exists) Then
Set shTarget4 = ThisWorkbook.Sheets("4")
Else
Resume

There's no need for me to keep the original sheet's data as this is not the source sheet.
The data from the first sheet comes from its source via means of a macro, so if I ever need to refer to the source data then it wont be an issue.
Also, the other reason is that each sheet will be saved as individual workbooks in a folder when my macro's are run so that I can send off each individual sheet to their respective departments.

 

[Andrzejek]

Eitel13,
You may simple state what it is that you want to happen, and your code may get very, very short.

Something like:

[pre]
For X = 1 To 6
Filter Source Where Col F = X
If records exist
Create a new worksheet "Dept " & X
Copy filtered rows from Source
Paste rows into "Dept " & X worksheet
End If
Next X
Delete Source
[/pre]


---- Andy

There is a great need for a sarcasm font.

 

[SkipVought]

...and this type of Delete method will not give you the desired effect, since,
let’s say i = 2
You Delete row 2. Fine!
HOWEVER, what Was row 3, is now row 2! TILT!!! Your code will NEVER see row 3. Row 4 becomes row 3.

And so it goes.

In general, when deleting rows, start with the LAST row and incriment in reverse.

'Do while that will read the data of the cells in the 5th column and 
‘if it is match for the string variables, it will move the entire row to the worksheet of the same name
Do While i <= 200
    '2
    If Cells(i, 6).Value = "2" Then
    shSource.Rows(i).Copy
    shTarget1.Cells(a, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
‘...

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}

 

[SkipVought]

Since sheet “1” is your source...

'Assign string values to variables
Set shSource = ThisWorkbook.Sheets("1")

...Filter/Copy loop...
[pre]
For X = 2 To 7
Filter Source Where Col F = X
If records exist
Create a new worksheet "Dept " & X
Copy filtered rows from Source
Paste rows into "Dept " & X worksheet
End If
Next X
Delete Source in “1” Filtering where col F > “1”
[/pre]

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}