I broke my code...

[tweek312]

I have this handy little piece of code that someone helped me create and now that I have modified the spreadsheet the code no longer works as expected; with the proper adjustments of course.

In the change of the spreadsheet I merely added 4 columns and moved the critera range. The span of the parts to be copied changed from 22 to 26 and the criteria range was formerly A535.

The problem lies within the catching of all the companies, for example DIS. When running the code the code will find the row with the DIS copy it and paste it into the proper sheet; however it does not go back and check for either another DIS or any of the other companies. I am not very good with VBA so go easy on me if its somthing really simple or lame.

Thanks

tW33k.

This is my adjusted code.

Public Sub ParseAllClientsList()
Application.ScreenUpdating = False
Dim DoCopy As Boolean
CriteriaRange = "D5:D36"

If Not SheetExists("All Clients") Then Exit Sub

With Sheets("All Clients")
For Each company In .Range(CriteriaRange)
DoCopy = True
Select Case Trim(UCase(company.Text))
Case "IND": TargSh = "Independent"
Case "UNI": TargSh = "Universal"
Case "MSFT": TargSh = "Microsoft"
Case "PAR": TargSh = "Paramount"
Case "DWS": TargSh = "Dreamworks"
Case "DIS": TargSh = "Disney"
Case "VEN": TargSh = "Ventura"
Case "PP": TargSh = "PreProduction"
Case "FOX": TargSh = "Fox"
Case Else
DoCopy = False
If Len(company.Text) > 0 Then
msg = "There is no sheet specified for : " & Chr(34) & company & Chr(34) & " ."
pt = MsgBox(msg, vbCritical, "Record not transfered")
End If
End Select


If DoCopy Then
If SheetExists(TargSh) Then
company.EntireRow.Copy
With Sheets(TargSh)
NxRow = .Cells(26, 1).End(xlUp).Row + 1
.Paste Destination:=.Range("A" & "5")
End With
End If 'do copy
End If 'sheet exists
Next company
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Private Function SheetExists(sname) As Boolean
' Returns TRUE if sheet exists in the active workbook
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then
SheetExists = True
Else
SheetExists = False
msg = "The sheet : " & Chr(34) & sname & Chr(34) & " does not exist ."
pt = MsgBox(msg, vbCritical, "Record not transfered")
End If
End Function

Old Code that works

Public Sub ParseAllClientsList()
Application.ScreenUpdating = False
Dim DoCopy As Boolean
CriteriaRange = "A5:A35"

If Not SheetExists("All Clients") Then Exit Sub

With Sheets("All Clients")
For Each company In .Range(CriteriaRange)
DoCopy = True
Select Case Trim(UCase(company.Text))
Case "IND": TargSh = "Independent"
Case "UNI": TargSh = "Universal"
Case "MSFT": TargSh = "Microsoft"
Case "PAR": TargSh = "Paramount"
Case "DWS": TargSh = "Dreamworks"
Case "DIS": TargSh = "Disney"
Case "LG": TargSh = "LionsGate"
Case "PP": TargSh = "PreProduction"
Case Else
DoCopy = False
If Len(company.Text) > 0 Then
msg = "There is no sheet specified for : " & Chr(34) & company & Chr(34) & " ."
pt = MsgBox(msg, vbCritical, "Record not transfered")
End If
End Select


If DoCopy Then
If SheetExists(TargSh) Then
company.EntireRow.Copy
With Sheets(TargSh)
NxRow = .Cells(22, 1).End(xlUp).Row + 1
.Paste Destination:=.Range("A" & NxRow)
End With
End If 'do copy
End If 'sheet exists
Next company
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Private Function SheetExists(sname) As Boolean
' Returns TRUE if sheet exists in the active workbook
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then
SheetExists = True
Else
SheetExists = False
msg = "The sheet : " & Chr(34) & sname & Chr(34) & " does not exist ."
pt = MsgBox(msg, vbCritical, "Record not transfered")
End If
End Function

 

[Zathras]

No time to study the code, but I do see that you replaced
[tt]
.Paste Destination:=.Range("A" & NxRow)
[/tt]
with
[tt]
.Paste Destination:=.Range("A" & "5")
[/tt]
If you always want to paste into cell A5 and only cell A5, that's ok by me, but it seems a bit strange.

 

[tweek312]

I thought that someone might point that out... For some reason that was a part of the code that broke as well. Even though none of the rows changed (ie I didnt add or remove any) the code was pasting in the wrong spot. I changed it to "5" instead of NxRow when I was fiddling with the code. You are right it should be NxRow because I want additional entires to go below the existing.

Thanks!

 

[PCLewis]

Ar eyou positive your code stops running or is it just that you never see the expected results so assume it was not running? Put a breakpoint on your If DoCopy line and check the value of TargSh after each iteration.

NxRow = .Cells(26, 1).End(xlUp).Row + 1

is one line you changed. You say you hard coded the next line: .Paste Destination:=.Range("A" & "5") because you were nto getting the results you expected. What did you get in fact?

The code as written would have pasted to the 'A' column up until row 26 and then forever more would have pasted to that row. So of course if your target sheets have data in them for cells A1-A26, you may not think it's pasting but it probably is.

 

[tweek312]

The problem lies in the pasting. It looks as if the code works fine in regards to filtering, copying, and pasting the data to the correct sheet. Now the problem lies in where on the sheet it is puting the data. The data should be pasted on the intersection of A5 and xlDown. Please see picture as follows.

 

[PCLewis]

If your code said:

NxRow = .Cells(26, 1).End(xlUp).Row + 1
.Paste Destination:=.Range("A" & NxRow)

And it pasted in cell A25 given the screen shot you pasted then that is correct behaviour. I would expect that if A24 and A26 started off blank, then the first time you ran, it would paste at A25. The second time, at A26. All subsequent times it would paste at A25.

The code says to go to Cell A26, move up to the first non empty cell then move down one cell and paste the content of the clipboard there.

If you wanted the code to go to A5 and then move down to the first empty cell then you would have left the code as it was: i.e.

NxRow = .Cells(22, 1).End(xlUp).Row + 1
.Paste Destination:=.Range("A" & NxRow)

The reason is that if you go to Cell A22, then go up to the first non-empty cell, then go down by one cell, you will be at an empty cell.

I can't see why you have run into trouble with something so simple (when you had it working) unless you did not realuse what the xlUp was doing? Perhaps you thought it was a worksheet label?

If you type ?xlup in your immediate window, and press enter, you will see the answer of -4162.

 

[tweek312]

Heh.. Silly me... Always so anxious to make changes to the code. It seems so obvious now... =D

Thanks All!

Code works great... Just like it did before.