Help needed: No Experience At All

[YellowLabPro]

I have some code and I need to duplicate it w/ different arguments. But I am unable to get it to perform successfully.
The code's purpose is to find everything w/ a ~P and put it on a sheet called ParentData and then strip out the ~P and the leading space. This works fine. It is the following code that is not working properly. It seems to run fine,e.g. no errors returned, but does not copy and paste the data into the sheet. The hour glass presents itself and when the hour glass is done it does not paste the code.
The second code is instructed to find ~C and put it on a sheet called ChildData, then remove the ~C and the leading space.

[vba]Code 1 = ParentData
______________________________________________________________

Sub ConsolidateandFilterParents()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim wks1 As Worksheet, wks2 As Worksheet
Dim DestSheet As Worksheet
Dim lngRow As Long
Dim rngFirst As Range
Dim rngAllRecords As Range
Dim rngtoSearch As Range
Dim RngFound As Range
Dim c As Variant
Dim rngDestination As Range
Set wks1 = Sheets("TGFF")
Set wks2 = Sheets("TGVB")
Set DestSheet = Sheets("ParentData")

With DestSheet
lngRow = Sheets("ParentData").Range("A65536").End(xlUp).Row + 1
End With
Set rngtoSearch = wks1.Columns("E")
Set rngDestination = DestSheet.Cells(2, 1)
Set RngFound = rngtoSearch.Find _
(What:="~~P", LookIn:=xlValues, LookAt:=xlPart)
If Not RngFound Is Nothing Then
On Error Resume Next

Set rngFirst = RngFound
Set rngAllRecords = RngFound
Do
Set rngAllRecords = Union(rngAllRecords, RngFound)
Set RngFound = rngtoSearch.FindNext(RngFound)
DestSheet.Cells(lngRow, 1) = RngFound.Offset(0, -4)
DestSheet.Cells(lngRow, 2) = RngFound
DestSheet.Cells(lngRow, 3) = RngFound
lngRow = lngRow + 1
Loop Until RngFound.Address = rngFirst.Address

End If
Set rngAllRecords = Nothing
Set RngFound = Nothing
Set rngtoSearch = wks2.Columns("E")
Set rngDestination = DestSheet.Cells(lngRow + 1, 1)
Set RngFound = rngtoSearch.Find _
(What:="~~P", LookIn:=xlValues, LookAt:=xlPart)
If Not RngFound Is Nothing Then
On Error Resume Next

Set rngFirst = RngFound
Set rngAllRecords = RngFound
Do
Set rngAllRecords = Union(rngAllRecords, RngFound)
Set RngFound = rngtoSearch.FindNext(RngFound)
DestSheet.Cells(lngRow, 1) = RngFound.Offset(0, -4)
DestSheet.Cells(lngRow, 2) = RngFound
DestSheet.Cells(lngRow, 3) = RngFound
DestSheet.Cells(lngRow, 3).Replace What:="~~P", Replacement:="", LookAt:=xlPart

lngRow = lngRow + 1
Loop Until RngFound.Address = rngFirst.Address


End If
Set rngAllRecords = Nothing
Set RngFound = Nothing

Call Trimparent
Call LeadingSpaces
Sheets("ParentData").Range("C1") = "ParentTrimmed"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
'
'
Sub Trimparent()
Dim TrimRng As Range
Set TrimRng = Sheets("ParentData").Columns(3)
TrimRng.Replace What:="~~P", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End Sub

______________________________________________________________

Sub Trimchild()
Dim TrimRng As Range
Set TrimRng = Sheets("ChildData").Columns(3)
TrimRng.Replace What:="~~C", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End Sub
_______________________________________________________________

Sub LeadingSpaces()
Dim TrimRng2 As Range
Set TrimRng2 = Sheets("ParentData").Range(Cells(2, 3), Cells(65536, 3).End(xlUp))
For Each c In TrimRng2
c.Offset(0, 1) = Trim(c)
Next c
Sheets("ParentData").Columns(3).Delete
End Sub[/vba]
_______________________________________________________________

[vba]
Code 2- ChildData, Which does not work

Sub ConsolidateandFilterChild()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim wks1 As Worksheet, wks2 As Worksheet
Dim DestSheet As Worksheet
Dim lngRow As Long
Dim rngFirst As Range
Dim rngAllRecords As Range
Dim rngtoSearch As Range
Dim RngFound As Range
Dim c As Variant
Dim rngDestination As Range
Set wks1 = Sheets("TGFF")
Set wks2 = Sheets("TGVB")
Set DestSheet = Sheets("ChildData")

With DestSheet
lngRow = Sheets("ChildData").Range("A65536").End(xlUp).Row + 1
End With
Set rngtoSearch = wks1.Columns("E")
Set rngDestination = DestSheet.Cells(2, 1)
Set RngFound = rngtoSearch.Find _
(What:="~~C", LookIn:=xlValues, LookAt:=xlPart)
If Not RngFound Is Nothing Then
On Error Resume Next

Set rngFirst = RngFound
Set rngAllRecords = RngFound
Do
Set rngAllRecords = Union(rngAllRecords, RngFound)
Set RngFound = rngtoSearch.FindNext(RngFound)
DestSheet.Cells(lngRow, 1) = RngFound.Offset(0, -4)
DestSheet.Cells(lngRow, 2) = RngFound
DestSheet.Cells(lngRow, 3) = RngFound
lngRow = lngRow + 1
Loop Until RngFound.Address = rngFirst.Address

End If
Set rngAllRecords = Nothing
Set RngFound = Nothing
Set rngtoSearch = wks2.Columns("E")
Set rngDestination = DestSheet.Cells(lngRow + 1, 1)
Set RngFound = rngtoSearch.Find _
(What:="~~C", LookIn:=xlValues, LookAt:=xlPart)
If Not RngFound Is Nothing Then
On Error Resume Next

Set rngFirst = RngFound
Set rngAllRecords = RngFound
Do
Set rngAllRecords = Union(rngAllRecords, RngFound)
Set RngFound = rngtoSearch.FindNext(RngFound)
DestSheet.Cells(lngRow, 1) = RngFound.Offset(0, -4)
DestSheet.Cells(lngRow, 2) = RngFound
DestSheet.Cells(lngRow, 3) = RngFound
DestSheet.Cells(lngRow, 3).Replace What:="~~C", Replacement:="", LookAt:=xlPart

lngRow = lngRow + 1
Loop Until RngFound.Address = rngFirst.Address


End If
Set rngAllRecords = Nothing
Set RngFound = Nothing

Call Trimchild
Call LeadingSpaces
Sheets("ChildData").Range("C1") = "ChildTrimmed"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]

Thanks
YLP

[johnske]

Hi YellowLabPro, welcome to VBAX. I hope you don't mind, but I've wrapped your code in VBA tags to make it more readable for others

[YellowLabPro]

No, Dont mind at all. Thanks.
In reviewing the code, you did not find anything, you just added the tags, correct?


YLP

[johnske]

Correct - didn't look, just tagged code

[johnske]

Had a quick look... This would be easier if we had an attached copy of your workbook to work with (remove any sensitive data of course) and a better idea of what the intent is (we can get that by running the code that does work) and how the data's laid out. The main problem being that there is a lot of superfluous code to wade through, e.g.
[vba]Sub Trimparent()
Dim TrimRng As Range
Set TrimRng = Sheets("ParentData").Columns(3)
TrimRng.Replace What:="~~P", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End Sub[/vba]
can be written as a single line:
[vba]Sub Trimparent()
Sheets("ParentData").Columns(3).Replace What:="~~P", Replacement:="", MatchCase:=False
End Sub[/vba]and you have at least one undeclared variable (c) so you're not using Option Explicit

[YellowLabPro]

How would you like to have me attach the workbook?

[johnske]

You can upload it as is, but zipping it is probably better on resources... Go to 'Go Advanced' then scroll down to 'Manage Attachments' > 'Upload'

[YellowLabPro]

Good Morning,
I spent a considerable amount of time trying to reduce the size of the workbook down to permit it to be uploaded; after many futile attempts, I started copying the raw data to a new workbook. In doing so, I re-ran the code and it worked, all except the last piece of code, which is its function is to remove the leading spaces from "ChildData". So I am posting the code here and going to upload the new file. The code works if it is run from its own module, but not in the combined module which calls each of the independent modules.

[vba]
Sub ConsolidateandFilterParents()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim wks1 As Worksheet, wks2 As Worksheet
Dim DestSheet As Worksheet
Dim lngRow As Long
Dim rngFirst As Range
Dim rngAllRecords As Range
Dim rngtoSearch As Range
Dim RngFound As Range
Dim c As Variant
Dim rngDestination As Range
Set wks1 = Sheets("TGFF")
Set wks2 = Sheets("TGVB")
Set DestSheet = Sheets("ParentData")

With DestSheet
lngRow = Sheets("ParentData").Range("A65536").End(xlUp).Row + 1
End With
Set rngtoSearch = wks1.Columns("E")
Set rngDestination = DestSheet.Cells(2, 1)
Set RngFound = rngtoSearch.Find _
(What:="~~P", LookIn:=xlValues, LookAt:=xlPart)
If Not RngFound Is Nothing Then
On Error Resume Next

Set rngFirst = RngFound
Set rngAllRecords = RngFound
Do
Set rngAllRecords = Union(rngAllRecords, RngFound)
Set RngFound = rngtoSearch.FindNext(RngFound)
DestSheet.Cells(lngRow, 1) = RngFound.Offset(0, -4)
DestSheet.Cells(lngRow, 2) = RngFound
DestSheet.Cells(lngRow, 3) = RngFound
lngRow = lngRow + 1
Loop Until RngFound.Address = rngFirst.Address

End If
Set rngAllRecords = Nothing
Set RngFound = Nothing
Set rngtoSearch = wks2.Columns("E")
Set rngDestination = DestSheet.Cells(lngRow + 1, 1)
Set RngFound = rngtoSearch.Find _
(What:="~~P", LookIn:=xlValues, LookAt:=xlPart)
If Not RngFound Is Nothing Then
On Error Resume Next

Set rngFirst = RngFound
Set rngAllRecords = RngFound
Do
Set rngAllRecords = Union(rngAllRecords, RngFound)
Set RngFound = rngtoSearch.FindNext(RngFound)
DestSheet.Cells(lngRow, 1) = RngFound.Offset(0, -4)
DestSheet.Cells(lngRow, 2) = RngFound
DestSheet.Cells(lngRow, 3) = RngFound
DestSheet.Cells(lngRow, 3).Replace What:="~~P", Replacement:="", LookAt:=xlPart

lngRow = lngRow + 1
Loop Until RngFound.Address = rngFirst.Address


End If
Set rngAllRecords = Nothing
Set RngFound = Nothing

Call Trimparent
Call LeadingSpacesParent
Sheets("ParentData").Range("C1") = "ParentTrimmed"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Trimparent()
Dim TrimRng As Range
Set TrimRng = Sheets("ParentData").Columns(3)
TrimRng.Replace What:="~~P", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End Sub
Sub LeadingSpacesParent()
Dim TrimRng2 As Range
Set TrimRng2 = Sheets("ParentData").Range(Cells(2, 3), Cells(65536, 3).End(xlUp))
For Each c In TrimRng2
c.Offset(0, 1) = Trim(c)
Next c
Sheets("ParentData").Columns(3).Delete
Call ConsolidateandFilterChild
Call Trimchild
Call LeadingSpacesChild
End Sub
Sub ConsolidateandFilterChild()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim wks1 As Worksheet, wks2 As Worksheet
Dim DestSheet As Worksheet
Dim lngRow As Long
Dim rngFirst As Range
Dim rngAllRecords As Range
Dim rngtoSearch As Range
Dim RngFound As Range
Dim c As Variant
Dim rngDestination As Range
Set wks1 = Sheets("TGFF")
Set wks2 = Sheets("TGVB")
Set DestSheet = Sheets("ChildData")

With DestSheet
lngRow = Sheets("ChildData").Range("A65536").End(xlUp).Row + 1
End With
Set rngtoSearch = wks1.Columns("E")
Set rngDestination = DestSheet.Cells(2, 1)
Set RngFound = rngtoSearch.Find _
(What:="~~C", LookIn:=xlValues, LookAt:=xlPart)
If Not RngFound Is Nothing Then
On Error Resume Next

Set rngFirst = RngFound
Set rngAllRecords = RngFound
Do
Set rngAllRecords = Union(rngAllRecords, RngFound)
Set RngFound = rngtoSearch.FindNext(RngFound)
DestSheet.Cells(lngRow, 1) = RngFound.Offset(0, -4)
DestSheet.Cells(lngRow, 2) = RngFound
DestSheet.Cells(lngRow, 3) = RngFound
lngRow = lngRow + 1
Loop Until RngFound.Address = rngFirst.Address

End If
Set rngAllRecords = Nothing
Set RngFound = Nothing
Set rngtoSearch = wks2.Columns("E")
Set rngDestination = DestSheet.Cells(lngRow + 1, 1)
Set RngFound = rngtoSearch.Find _
(What:="~~C", LookIn:=xlValues, LookAt:=xlPart)
If Not RngFound Is Nothing Then
On Error Resume Next

Set rngFirst = RngFound
Set rngAllRecords = RngFound
Do
Set rngAllRecords = Union(rngAllRecords, RngFound)
Set RngFound = rngtoSearch.FindNext(RngFound)
DestSheet.Cells(lngRow, 1) = RngFound.Offset(0, -4)
DestSheet.Cells(lngRow, 2) = RngFound
DestSheet.Cells(lngRow, 3) = RngFound
DestSheet.Cells(lngRow, 3).Replace What:="~~C", Replacement:="", LookAt:=xlPart

lngRow = lngRow + 1
Loop Until RngFound.Address = rngFirst.Address


End If
Set rngAllRecords = Nothing
Set RngFound = Nothing

'Call Trimchild
'Call LeadingSpacesChild
Sheets("ChildData").Range("C1") = "ChildTrimmed"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Trimchild()
Dim TrimRng As Range
Set TrimRng = Sheets("ChildData").Columns(3)
TrimRng.Replace What:="~~C", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False

End Sub
Sub LeadingSpacesChild()
Dim TrimRng2 As Range
Set TrimRng2 = Sheets("ChildData").Range(Cells(2, 3), Cells(65536, 3).End(xlUp))
For Each c In TrimRng2
c.Offset(0, 1) = Trim(c)
Next c
Sheets("ChildData").Columns(3).Delete
End Sub

[/vba]

[johnske]

Does this do what you want?

[vba]Option Explicit
'
Sub ConsolidateandFilterAll()
'
Dim FirstAddress As String, Cell As Range
'
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'
'========================
With Sheets("TGFF").Columns("E")
Set Cell = .Find(What:="~~P", LookIn:=xlValues, LookAt:=xlPart)
'
If Not Cell Is Nothing Then
'
FirstAddress = Cell.Address
'
Do
With Sheets("ParentData").Range("A" & Rows.Count).End(xlUp)
.Offset(1, 0) = Cell.Offset(0, -4)
.Offset(1, 1) = Cell
.Offset(1, 2) = Cell
End With
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
'
End If
'
'---------------------------------------------
'
Set Cell = .Find(What:="~~C", LookIn:=xlValues, LookAt:=xlPart)
'
If Not Cell Is Nothing Then
'
FirstAddress = Cell.Address
'
Do
With Sheets("ChildData").Range("A" & Rows.Count).End(xlUp)
.Offset(1, 0) = Cell.Offset(0, -4)
.Offset(1, 1) = Cell
.Offset(1, 2) = Cell
End With
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
'
End If
End With
'
'========================
'
With Sheets("TGVB").Columns("E")
Set Cell = .Find(What:="~~P", LookIn:=xlValues, LookAt:=xlPart)
'
If Not Cell Is Nothing Then
'
FirstAddress = Cell.Address
'
Do
With Sheets("ParentData").Range("A" & Rows.Count).End(xlUp)
.Offset(1, 0) = Cell.Offset(0, -4)
.Offset(1, 1) = Cell
.Offset(1, 2) = Cell
End With
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End If
'
'---------------------------------------------
'
Set Cell = .Find(What:="~~C", LookIn:=xlValues, LookAt:=xlPart)
'
If Not Cell Is Nothing Then
'
FirstAddress = Cell.Address
'
Do
With Sheets("ChildData").Range("A" & Rows.Count).End(xlUp)
.Offset(1, 0) = Cell.Offset(0, -4)
.Offset(1, 1) = Cell
.Offset(1, 2) = Cell
End With
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
'
End If
End With
'========================
'
'
With Sheets("ParentData")
.Columns(3).Replace What:="~~P", Replacement:="", MatchCase:=False
For Each Cell In .Range("C2", Range("C" & Rows.Count).End(xlUp).Address)
Cell = Trim(Cell)
Next
.Range("C1") = "ParentTrimmed"
End With
'
'---------------------------------------------
'
With Sheets("ChildData")
.Columns(3).Replace What:="~~C", Replacement:="", MatchCase:=False
For Each Cell In .Range("C2", Range("C" & Rows.Count).End(xlUp).Address)
Cell = Trim(Cell)
Next
.Range("C1") = "ChildTrimmed"
End With
'
'---------------------------------------------
'
Set Cell = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'
End Sub[/vba]

[YellowLabPro]

Yes, Great and Thanks!
I replaced my code w/ yours. As I mentioned in my initial post, I am just beginning w/ VBA. I am curious if you were able to determine why the last routine in the code I posted was not able to remove the leading spaces from the "ChildData" worksheet, it works on "ParentData"?

Thank you very much,

YLP

[Zack Barresse]

YLP, Hi!

Your procedure might not have worked because of your referencing ...

[vba]Set TrimRng2 = Sheets("ParentData").Range(Cells(2, 3), Cells(65536, 3).End(xlUp))[/vba]

What you want to look at is this part here..

[vba]Cells(2, 3), Cells(65536[/vba]

Notice that neither one of these have references to any parent sheet? You must explicitly reference your objects - especially when working with multipe sheets. The same goes for working with multiple workbooks. A good example might be ...

[vba]Set TrimRng2 = Sheets("ParentData").Range(Sheets("ParentData").Cells(2, 3), _
Sheets("ParentData").Cells(65536, 3).End(xlUp))[/vba]

When calling procedures from subs I generally tend to make them functions and pass which variable (sheet in your case) you'd like to use it on, or you can leave it as a Sub and pass a variable as well. Something like this ...

[vba]Sub Trimchild(wks As Worksheet)
wks.Columns(3).Replace What:="~~C", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End Sub

Sub LeadingSpaces(wks As Worksheet)
Dim c as Range
For Each c In wks.Range(wks.Cells(2, 3), wks.Cells(wks.Rows.Count, 3).End(xlUp))
c.Offset(0, 1) = Trim(c)
Next c
wks.Columns(3).Delete
End Sub
'// I don't understand WHY you would delete column 3 after working on it either...[/vba]


[vba] Call Trimchild(Sheets("ChildData"))
Call LeadingSpaces(Sheets("ParentData"))[/vba]

HTH

[johnske]

YLP, some of the problems were due to not using Option Explicit. This forces you to declare all variables and thus if you misspell a variable name it's "caught" because visual basic reads it as an undeclared variable and raises an error message to let you know.

However, the one that confuses the hell out of visual basic is having two procedures with the same name in the same workbook. As you had (I think) every single procedure duplicated, visual basic was really confused and this was probably causing erratic behaviour. (The main problem being that when a procedure was called, there were two procedures with the same name. This would normally raise an error and cause it to crash except that your On Error Resume Next prevented that and the code was simply bypassed and not executed)

[johnske]

OK, now that it works to your satisfaction, we can look at the code and note that we are doing similar things four times, so we can simplify all that to something like this.

[vba]Option Explicit
'
Sub ConsolidateAll()
'
Dim FromSheet As String, ToSheet As String, Mymarker As String
Dim Cell As Range, FirstAddress As String
'
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
'
FromSheet = "TGFF"
ToSheet = "ParentData": Mymarker = "~~P": GoSub ConsolidateIt
ToSheet = "ChildData": Mymarker = "~~C": GoSub ConsolidateIt
'
FromSheet = "TGVB"
ToSheet = "ParentData": Mymarker = "~~P": GoSub ConsolidateIt
ToSheet = "ChildData": Mymarker = "~~C": GoSub ConsolidateIt
'
Sheets("ParentData").[C1] = "ParentTrimmed"
Sheets("ChildData").[C1] = "ChildTrimmed"
'
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
'
Exit Sub '(End of Main Procedure)
'
'
'**************************************************
ConsolidateIt: '(Sub Procedure)
'
With Sheets(FromSheet).Columns("E")
Set Cell = .Find(what:=Mymarker, LookIn:=xlValues, LookAt:=xlPart)
'
If Not Cell Is Nothing Then
'
FirstAddress = Cell.Address
'
Do
With Sheets(ToSheet).Range("A" & Rows.Count).End(xlUp)
.Offset(1, 0) = Cell.Offset(0, -4)
.Offset(1, 1) = Cell
.Offset(1, 2) = Cell
.Offset(1, 2).Replace what:=Mymarker, replacement:="", MatchCase:=False
.Offset(1, 2) = Trim(.Offset(1, 2))
End With
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
'
End If
End With
'
Set Cell = Nothing
Return
'
End Sub[/vba]HTH

[YellowLabPro]

Thanks. I am back at this project. I am going to leave the part that Johnske has fixed alone for now, since it is working and come back to it later, studying what Johnske and Zack have offered.

Moving to the next step, the following code works fine currently. But I need to add a column of information to the source worksheet and when I do this, the code does not work. I cannot tell if by adding the code the range gets screwed up or if the column reference "E" is the culprit. I changed "E" to "F", but that did not work, so I am back to square 1.

The code instructions are to go get the data from TGFF and TGVB and put it on the Data worksheet, which is working fine now. But when I insert a new column, "A", which will contain the name of the original data source location, the code does not function, it does not copy and paste any data onto the destination sheet "Data".

[vba]
Sub ConsolidateandFilter()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wks1 As Worksheet, wks2 As Worksheet
Dim DestSheet As Worksheet
Dim lngRow As Long
Dim rngFirst As Range
Dim rngAllRecords As Range
Dim rngtoSearch As Range
Dim RngFound As Range
Dim c As Variant
Dim rngDestination As Range
Set wks1 = Sheets("TGFF")
Set wks2 = Sheets("TGVB")
Set DestSheet = Sheets("Data")

With DestSheet
lngRow = Range("A65536").End(xlUp).Row
End With
Set rngtoSearch = wks1.Columns("E")
Set rngDestination = DestSheet.Cells(2, 1)
Set RngFound = rngtoSearch.Find _
(What:="~~", LookIn:=xlValues, LookAt:=xlPart)
If Not RngFound Is Nothing Then
On Error Resume Next

Set rngFirst = RngFound
Set rngAllRecords = RngFound
Do
Set rngAllRecords = Union(rngAllRecords, RngFound)
Set RngFound = rngtoSearch.FindNext(RngFound)
Loop Until RngFound.Address = rngFirst.Address
rngAllRecords.EntireRow.Copy rngDestination.EntireRow
MsgBox "TGFF " & rngAllRecords.Count

End If
Set rngAllRecords = Nothing
Set RngFound = Nothing


Set rngtoSearch = wks2.Columns("E")
With DestSheet
lngRow = Range("A65536").End(xlUp).Row
End With
Set rngDestination = DestSheet.Cells(65536, 1).End(xlUp)
Set RngFound = rngtoSearch.Find _
(What:="~~", LookIn:=xlValues, LookAt:=xlPart)
If Not RngFound Is Nothing Then
On Error Resume Next
lngRow = rngDestination.Row
Set rngFirst = RngFound
Set rngAllRecords = RngFound
Do
Set rngAllRecords = Union(rngAllRecords, RngFound)
Set RngFound = rngtoSearch.FindNext(RngFound)
Loop Until RngFound.Address = rngFirst.Address
rngAllRecords.EntireRow.Copy rngDestination.EntireRow
MsgBox "TGVB " & rngAllRecords.Count

End If
Set rngAllRecords = Nothing
Set RngFound = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'Call ConsolidateandFilterParents
End Sub

[/vba]

Thanks,

YLP

[YellowLabPro]

One other question, I am not receiving notifications via email, although I did get one yesterday, when there are new posts to this thread. I am fairly sure I have the option selected to perform this task. Can you advise please?

Thanks,

YLP

[johnske]

Hi YLP,

I think if you look at your coding practices, cut out all unnecessary code and variables you'd simplify this greatly, make it clearer, and probably be able to sort most of this out for yourself.

For instance, you have eight object variables, one of which is wks1. This particular variable is only used once, so in that case it's better to just use it directly and not declare it as a variable at all because you have four lines of code...

[vba]Dim wks1 As Worksheet
'more
Set wks1 = Sheets("TGFF")
'more
Set rngtoSearch = wks1.Columns("E")
'more
Set wks1 = Nothing[/vba]

When you could just use one line...
[vba]Set rngtoSearch = Sheets("TGFF").Columns("E")[/vba]

If you go through your code and look at what rngtoSearch is used for, you can even eliminate the line above(!), as you have eight lines of code using rngtoSearch...

[vba]Dim rngtoSearch As Range
'more
'-----------------
Set rngtoSearch = wks1.Columns("E")
'more
Set RngFound = rngtoSearch.Find 'etc
'more
Set RngFound = rngtoSearch.FindNext(RngFound)
'more
'-----------------
Set rngtoSearch = wks2.Columns("E")
'more
Set RngFound = rngtoSearch.Find 'etc
'more
Set RngFound = rngtoSearch.FindNext(RngFound)
'more
'-----------------
'more
Set rngtoSearch = Nothing
'-----------------[/vba]
When you can just use With and End With to get...
[vba]'-----------------
With Sheets("TGFF").Columns("E")
.Find 'etc
'more
.FindNext(RngFound)
End with
'-----------------
With Sheets("TGVB").Columns("E")
.Find 'etc
'more
.FindNext(RngFound)
End with
'-----------------[/vba]
If you keep going in this vein with you'll find quite a few more variables and lines of code that can also be eliminated.

I've already done this for the previous code you presented, and that process allowed me to get at the underlying logic involved, and once this is found you can then simplify it even further - as I've shown for your benefit in the previous posts.

I certainly don't feel like starting this process all over on this new (but remarkably similar) piece of code when this is something that can be readily done by yourself, so I'll just tell you how.

BTW: Lose the two On Error Resume Next's - they're not needed. Only one is needed at the best of times and when not used properly they can just hide problems.

HTH,
John

[YellowLabPro]

John,
Thanks very much for your time. I would like to say that I have never written any code and just started reading code yesterday. This was written for me by someone else. So the things you are pointing out, I will certainly follow your advice, but all of this is really out of my scope at this point and time and I am piecing it together as I go.
As to the immediate use of this code, (please be patient w/ me :-) ), in your reply post, do your instructions show me the error of my code and should I replace it w/ your code. It all still looks very foreign to me.

Original Issue:
Moving to the next step, the following code works fine currently. But I need to add a column of information to the source worksheet and when I do this, the code does not work. I cannot tell if by adding the code the range gets screwed up or if the column reference "E" is the culprit. I changed "E" to "F", but that did not work, so I am back to square 1.

The code instructions are to go get the data from TGFF and TGVB and put it on the Data worksheet, which is working fine now. But when I insert a new column, "A", which will contain the name of the original data source location, the code does not function, it does not copy and paste any data onto the destination sheet "Data".


Thanks for your assistance and patience.

YLP

[johnske]

I didn't even TRY to untangle the spaghetti this time, I just used your description of what was wanted.

If this does what you want, please mark the thread solved (use thread tools) and if you have any new questions please start a new thread.

[vba]Option Explicit
Sub ConsolidateandFilter()
'
Dim FirstAddress As String, Cell As Range
'
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
'
'=================================
With Sheets("TGFF").Columns("E")
Set Cell = .Find(What:="~~", LookIn:=xlValues)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
'
Do
Sheets("TGFF").Range("A" & Cell.Row, "IU" & Cell.Row).Copy _
Sheets("Data").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("Data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) _
= "Sheet TGFF, Row " & Cell.Row
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
'
End If
End With
'
'=================================
'
With Sheets("TGVB").Columns("E")
Set Cell = .Find(What:="~~", LookIn:=xlValues)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
'
Do
Sheets("TGVB").Range("A" & Cell.Row, "IU" & Cell.Row).Copy _
Sheets("Data").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("Data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) _
= "Sheet TGVB, Row " & Cell.Row
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
'
End If
End With
'=================================
'
Set Cell = Nothing
'
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
'
End Sub[/vba]