Moving data from one sheet to multiple sheets - vba - vba

Question

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.
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.

Answer 1

Here's how I'd do it. Should be OK provided the values in Col F are valid sheet names.
Sub CopyData()
Dim shtSrc As Worksheet
Dim c As Range, ws, r As Long, v
Set shtSrc = ThisWorkbook.Sheets("Sheet1")
For Each c In shtSrc.Range(shtSrc.Cells(2, 6), shtSrc.Cells(Rows.Count, 6).End(xlUp)).Cells
v = c.Value
If Len(v) > 0 Then
With GetSheet(ThisWorkbook, v)
'first row with no value in ColF
r = .Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Row
If r < 3 Then r = 3 'start at 3rd row
.Rows(r).Value = c.EntireRow.Value 'copy row content (value only)
End With
End If
Next c
End Sub
'Return a worksheet from a workbook: if not there, create a new sheet
' with the supplied name and return that
Function GetSheet(wb As Workbook, theName) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Worksheets(theName)
On Error GoTo 0
If ws Is Nothing Then
Set ws = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
ws.Name = theName
End If
Set GetSheet = ws
End Function

Answer 2

as for your explicit question (looking for some If (sheet.name("4") exists) Then way) you could take advantage of this helper function:
Function IsSheetThere(shtName As String, sht As Worksheet) As Boolean
On Error Resume Next
Set sht = Worksheets(shtName)
IsSheetThere = Not sht Is Nothing
End Function
to be used like:
Dim targetSht As Worksheet
If IsSheetThere("4", targetSht) Then
... (code to handle existing sheet)
End If
While as for the more general request ("dynamic piece of code"), you could use AutoFilter() method of Range object to formerly filter your source sheet column F and then copy/paste values to proper target sheet in one shot
I'm assuming that:
"1" is the worksheet whose column 6 cells you want to loop through from row 3 to the last one and copy/paste entire rows to a target sheet whose name matches current cell value
source sheet column 6 has a header in row 2
Sub CopyRowData()
Dim sourceSht As Worksheet
Set sourceSht = ThisWorkbook.Sheets("1")
Dim iSht As Long
Dim targetSht As Worksheet
With sourceSht
With .Range("F2", .Cells(.Rows.Count, "F").End(xlUp))
For iSht = 2 To 7
If IsSheetThere(CStr(iSht), targetSht) Then
.AutoFilter Field:=1, Criteria1:=iSht
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then
Intersect(.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow, .Parent.UsedRange).Copy
With targetSht
.Cells(WorksheetFunction.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row), 1).PasteSpecial Paste:=xlPasteValues
.Cells.EntireColumn.AutoFit
End With
Application.CutCopyMode = False
End If
End If
Next
End With
.AutoFilterMode = False
End With
End Sub