Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
If product already exists continued
Apologies for the duplicate posting but I realised I replied to a question I
asked on the 9th May so not sure if it will get picked up. Hi, If I wanted to include another criteria how would I implement. I have now had to include a qty for possible price breaks. With the help of Joel today I mangaed to sort out my first module but can not get the module which copies the record to the destination file. Per helped me with this module I would like to add With DestSh Set C = .Columns("H").Find(what:=Qty, _ LookIn:=xlValues, lookat:=xlWhole) but it just not working for me. I have tried different ways but to no avail. Code below Sub Copy_To_Another_Workbook1() Dim SourceRange As Range Dim DestRange As Range Dim DestWB As Workbook Dim DestSh As Worksheet Dim Lr As Long Dim wsNew As Worksheet Dim myFile As String Const MyPassword As String = "mypsswrd" With Application ..ScreenUpdating = False ..EnableEvents = False End With If Worksheets("CurrentRecord").Range("F2").Value = 0 Then Exit Sub End If Customer = Worksheets("CurrentRecord").Range("F2").Value With Worksheets("CustomerLogSheet").Columns("A") Set C = .Columns("A").Find(what:=Customer, _ LookIn:=xlValues, lookat:=xlWhole) End With If C Is Nothing Then Application.Run "Copy_To_Workbooks4" Else Product = Worksheets("CurrentRecord").Range("E2").Value Qty = Worksheets("CurrentRecord").Range("H2").Value myFile = C.Offset(0, 1).Value Set DestWB = Workbooks.Open(myFile) 'Change the sheet name of the database workbook Set DestSh = DestWB.Sheets(1) DestSh.Unprotect Password:=MyPassword 'Change the Source Sheet and range Set SourceRange = ThisWorkbook.Sheets("CurrentRecord").Range("A2:H2" ) With DestSh '.Columns("E") Set C = .Columns("E") And .Columns("H").Find(what:=Product, _ LookIn:=xlValues, lookat:=xlWhole) Set C = .Columns("H").Find(what:=Qty, _ LookIn:=xlValues, lookat:=xlWhole) End With If C Is Nothing Then Lr = LastRow(DestSh) Set DestRange = DestSh.Range("A" & Lr + 1) Else Set DestRange = DestSh.Range("A" & C.Row) End If With SourceRange Set DestRange = DestRange.Resize(1, 8) End With DestRange.Value = SourceRange.Value DestSh.Protect Password:=MyPassword DestWB.Close savechanges:=True With Sheets("CurrentRecord") ..Unprotect Password:=MyPassword ..Range("A2").EntireRow.Delete ..Protect Password:=MyPassword End With 'End If With Application ..ScreenUpdating = True ..EnableEvents = True End With End Sub Thanks for any help or guidance you may have |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
If product already exists continued
I guess we are working a few different problems today, You need to check
column E for all values that match the product by using Find and Findnext method. Then stop when column H also matches. I use c.offset(0,3) where c is in column e and column H is 3 columns over to check the QTY. See code below. I added the declaration in the code below Dim firstAddr as string When using findNext it will go into an endless loop unless you compare again the first cell that is found. Sub Copy_To_Another_Workbook1() Dim SourceRange As Range Dim DestRange As Range Dim DestWB As Workbook Dim DestSh As Worksheet Dim Lr As Long Dim wsNew As Worksheet Dim myFile As String Dim firstAddr as string Const MyPassword As String = "mypsswrd" With Application .ScreenUpdating = False .EnableEvents = False End With If Worksheets("CurrentRecord").Range("F2").Value = 0 Then Exit Sub End If Customer = Worksheets("CurrentRecord").Range("F2").Value With Worksheets("CustomerLogSheet").Columns("A") Set c = .Columns("A").Find(what:=Customer, _ LookIn:=xlValues, lookat:=xlWhole) End With If c Is Nothing Then Application.Run "Copy_To_Workbooks4" Else Product = Worksheets("CurrentRecord").Range("E2").Value Qty = Worksheets("CurrentRecord").Range("H2").Value myFile = c.Offset(0, 1).Value Set DestWB = Workbooks.Open(myFile) 'Change the sheet name of the database workbook Set DestSh = DestWB.Sheets(1) DestSh.Unprotect Password:=MyPassword 'Change the Source Sheet and range Set SourceRange = ThisWorkbook.Sheets("CurrentRecord").Range("A2:H2" ) With DestSh Found = False Set c = .Columns("E").Find(what:=Product, _ LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then firstAddr = c.Address Do If c.Offset(0, 3) = Qty Then Found = True Exit Do End If Set c = .Columns("E").FindNext(after:=c) Loop While Not c Is Nothing And c.Address < firstAddr End If End With If Found = False Then Lr = LastRow(DestSh) Set DestRange = DestSh.Range("A" & Lr + 1) Else Set DestRange = DestSh.Range("A" & c.Row) End If With SourceRange Set DestRange = DestRange.Resize(1, 8) End With DestRange.Value = SourceRange.Value DestSh.Protect Password:=MyPassword DestWB.Close savechanges:=True With Sheets("CurrentRecord") .Unprotect Password:=MyPassword .Range("A2").EntireRow.Delete .Protect Password:=MyPassword End With 'End If With Application .ScreenUpdating = True .EnableEvents = True End With End Sub "winnie123" wrote: Apologies for the duplicate posting but I realised I replied to a question I asked on the 9th May so not sure if it will get picked up. Hi, If I wanted to include another criteria how would I implement. I have now had to include a qty for possible price breaks. With the help of Joel today I mangaed to sort out my first module but can not get the module which copies the record to the destination file. Per helped me with this module I would like to add With DestSh Set C = .Columns("H").Find(what:=Qty, _ LookIn:=xlValues, lookat:=xlWhole) but it just not working for me. I have tried different ways but to no avail. Code below Sub Copy_To_Another_Workbook1() Dim SourceRange As Range Dim DestRange As Range Dim DestWB As Workbook Dim DestSh As Worksheet Dim Lr As Long Dim wsNew As Worksheet Dim myFile As String Const MyPassword As String = "mypsswrd" With Application .ScreenUpdating = False .EnableEvents = False End With If Worksheets("CurrentRecord").Range("F2").Value = 0 Then Exit Sub End If Customer = Worksheets("CurrentRecord").Range("F2").Value With Worksheets("CustomerLogSheet").Columns("A") Set C = .Columns("A").Find(what:=Customer, _ LookIn:=xlValues, lookat:=xlWhole) End With If C Is Nothing Then Application.Run "Copy_To_Workbooks4" Else Product = Worksheets("CurrentRecord").Range("E2").Value Qty = Worksheets("CurrentRecord").Range("H2").Value myFile = C.Offset(0, 1).Value Set DestWB = Workbooks.Open(myFile) 'Change the sheet name of the database workbook Set DestSh = DestWB.Sheets(1) DestSh.Unprotect Password:=MyPassword 'Change the Source Sheet and range Set SourceRange = ThisWorkbook.Sheets("CurrentRecord").Range("A2:H2" ) With DestSh '.Columns("E") Set C = .Columns("E") And .Columns("H").Find(what:=Product, _ LookIn:=xlValues, lookat:=xlWhole) Set C = .Columns("H").Find(what:=Qty, _ LookIn:=xlValues, lookat:=xlWhole) End With If C Is Nothing Then Lr = LastRow(DestSh) Set DestRange = DestSh.Range("A" & Lr + 1) Else Set DestRange = DestSh.Range("A" & C.Row) End If With SourceRange Set DestRange = DestRange.Resize(1, 8) End With DestRange.Value = SourceRange.Value DestSh.Protect Password:=MyPassword DestWB.Close savechanges:=True With Sheets("CurrentRecord") .Unprotect Password:=MyPassword .Range("A2").EntireRow.Delete .Protect Password:=MyPassword End With 'End If With Application .ScreenUpdating = True .EnableEvents = True End With End Sub Thanks for any help or guidance you may have |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
If product already exists continued
Thanks Joel
Definately no cigar for me today. Yes the addition of the QTY gave me the same 2 issues with the same 2 modules I had before. So just to clarify if i wanted(more likely I missed) to add a NEW criteria I would set the new value (=WS, Range,Value) Then I would change Fom If c.Offset(0, 3) = Qty Then To If c.Offset(0, 3) = Qty And c.Offset(0, 5) = New Then I think I have got it. Thanks ever so much , truly appreciate all the help. Best regards "joel" wrote: I guess we are working a few different problems today, You need to check column E for all values that match the product by using Find and Findnext method. Then stop when column H also matches. I use c.offset(0,3) where c is in column e and column H is 3 columns over to check the QTY. See code below. I added the declaration in the code below Dim firstAddr as string When using findNext it will go into an endless loop unless you compare again the first cell that is found. Sub Copy_To_Another_Workbook1() Dim SourceRange As Range Dim DestRange As Range Dim DestWB As Workbook Dim DestSh As Worksheet Dim Lr As Long Dim wsNew As Worksheet Dim myFile As String Dim firstAddr as string Const MyPassword As String = "mypsswrd" With Application .ScreenUpdating = False .EnableEvents = False End With If Worksheets("CurrentRecord").Range("F2").Value = 0 Then Exit Sub End If Customer = Worksheets("CurrentRecord").Range("F2").Value With Worksheets("CustomerLogSheet").Columns("A") Set c = .Columns("A").Find(what:=Customer, _ LookIn:=xlValues, lookat:=xlWhole) End With If c Is Nothing Then Application.Run "Copy_To_Workbooks4" Else Product = Worksheets("CurrentRecord").Range("E2").Value Qty = Worksheets("CurrentRecord").Range("H2").Value myFile = c.Offset(0, 1).Value Set DestWB = Workbooks.Open(myFile) 'Change the sheet name of the database workbook Set DestSh = DestWB.Sheets(1) DestSh.Unprotect Password:=MyPassword 'Change the Source Sheet and range Set SourceRange = ThisWorkbook.Sheets("CurrentRecord").Range("A2:H2" ) With DestSh Found = False Set c = .Columns("E").Find(what:=Product, _ LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then firstAddr = c.Address Do If c.Offset(0, 3) = Qty Then Found = True Exit Do End If Set c = .Columns("E").FindNext(after:=c) Loop While Not c Is Nothing And c.Address < firstAddr End If End With If Found = False Then Lr = LastRow(DestSh) Set DestRange = DestSh.Range("A" & Lr + 1) Else Set DestRange = DestSh.Range("A" & c.Row) End If With SourceRange Set DestRange = DestRange.Resize(1, 8) End With DestRange.Value = SourceRange.Value DestSh.Protect Password:=MyPassword DestWB.Close savechanges:=True With Sheets("CurrentRecord") .Unprotect Password:=MyPassword .Range("A2").EntireRow.Delete .Protect Password:=MyPassword End With 'End If With Application .ScreenUpdating = True .EnableEvents = True End With End Sub "winnie123" wrote: Apologies for the duplicate posting but I realised I replied to a question I asked on the 9th May so not sure if it will get picked up. Hi, If I wanted to include another criteria how would I implement. I have now had to include a qty for possible price breaks. With the help of Joel today I mangaed to sort out my first module but can not get the module which copies the record to the destination file. Per helped me with this module I would like to add With DestSh Set C = .Columns("H").Find(what:=Qty, _ LookIn:=xlValues, lookat:=xlWhole) but it just not working for me. I have tried different ways but to no avail. Code below Sub Copy_To_Another_Workbook1() Dim SourceRange As Range Dim DestRange As Range Dim DestWB As Workbook Dim DestSh As Worksheet Dim Lr As Long Dim wsNew As Worksheet Dim myFile As String Const MyPassword As String = "mypsswrd" With Application .ScreenUpdating = False .EnableEvents = False End With If Worksheets("CurrentRecord").Range("F2").Value = 0 Then Exit Sub End If Customer = Worksheets("CurrentRecord").Range("F2").Value With Worksheets("CustomerLogSheet").Columns("A") Set C = .Columns("A").Find(what:=Customer, _ LookIn:=xlValues, lookat:=xlWhole) End With If C Is Nothing Then Application.Run "Copy_To_Workbooks4" Else Product = Worksheets("CurrentRecord").Range("E2").Value Qty = Worksheets("CurrentRecord").Range("H2").Value myFile = C.Offset(0, 1).Value Set DestWB = Workbooks.Open(myFile) 'Change the sheet name of the database workbook Set DestSh = DestWB.Sheets(1) DestSh.Unprotect Password:=MyPassword 'Change the Source Sheet and range Set SourceRange = ThisWorkbook.Sheets("CurrentRecord").Range("A2:H2" ) With DestSh '.Columns("E") Set C = .Columns("E") And .Columns("H").Find(what:=Product, _ LookIn:=xlValues, lookat:=xlWhole) Set C = .Columns("H").Find(what:=Qty, _ LookIn:=xlValues, lookat:=xlWhole) End With If C Is Nothing Then Lr = LastRow(DestSh) Set DestRange = DestSh.Range("A" & Lr + 1) Else Set DestRange = DestSh.Range("A" & C.Row) End If With SourceRange Set DestRange = DestRange.Resize(1, 8) End With DestRange.Value = SourceRange.Value DestSh.Protect Password:=MyPassword DestWB.Close savechanges:=True With Sheets("CurrentRecord") .Unprotect Password:=MyPassword .Range("A2").EntireRow.Delete .Protect Password:=MyPassword End With 'End If With Application .ScreenUpdating = True .EnableEvents = True End With End Sub Thanks for any help or guidance you may have |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Product Code and Product Description setup | Excel Worksheet Functions | |||
I need a product key for my Trail product, 2007 Microsoft Office s | Setting up and Configuration of Excel | |||
Chose a product and update related product variables | Excel Programming | |||
Convert numbers to text (from product id # to name of product) | Excel Programming | |||
Vlookup code product and to copy commentary with photo of the product in vba | Excel Programming |