Posts by Sharid

Sharid · Apr 7th 2020

I need some help on a loop and I can not work it out. I have been stuck on this bit for sometime. I posted on another forum see link Here . I have not had much luck and now I have posted here, hoping someone can help.

PROBLEM

Currently the code is not looping through all the products, it can take off the first, with child elements (THIS IS IMPORTANT). However it only does the first item over and over again.

My latest code is here or visit the above link for more information

Code

Private Sub CommandButton3_Click() 
Dim IE As Object
Dim url As String
Dim i As Long
Dim innerText As Variant
Dim HTMLDoc As Object
Dim doc As Object
Dim href As String
Dim lastrow As Long
Dim dd As Variant
Dim wks As Worksheet: Set wks = ThisWorkbook.Sheets("Sheet1")

'IE setup
Set IE = CreateObject("InternetExplorer.Application")
    With IE
        .Visible = True
        ' Sheet to get url off Sheet1 A2, Product from Sheet1 B2
        .Navigate2 Sheets("Sheet1").Range("A2").Value & Replace(Worksheets("Sheet1").Range("B2").Value, " ", "+")
    Do
        DoEvents
        Loop Until IE.readyState = READYSTATE_COMPLETE
                Set doc = IE.document
            While IE.readyState <> 4
        Wend
    End With
  
     For i = 0 To 20 ' This assumes there are 20 products, this wrong product AMOUNT will be dynamic
      
        'URL Link
              If doc.getElementsByClassName("vip")(i) Is Nothing Then
                    dd = doc.getElementsByClassName("vip")(0) '.innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1, "A").Value = "-"
                Else
                    dd = doc.getElementsByClassName("vip")(0).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1, "A").Value = dd
                    Cells.WrapText = False
               End If
     
        'Title
                If doc.getElementsByClassName("lvtitle")(i) Is Nothing Then
                    dd = doc.getElementsByClassName("lvtitle")(0) '.innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = "-"
                Else
                    dd = doc.getElementsByClassName("lvtitle")(0).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = dd
                    Cells.WrapText = False
                End If

        'Amount Sold
           If doc.getElementsByClassName("hotness-signal red")(i) Is Nothing Then
                    dd = doc.getElementsByClassName("hotness-signal red")(0) '.innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row + 1, "C").Value = "-"
                   dd1 = doc.getElementsByClassName("hotness-signal red")(1)
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "D").End(xlUp).Row + 1, "D").Value = "-"
                Else
                    dd = doc.getElementsByClassName("hotness-signal red")(0).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row + 1, "C").Value = dd
                    dd1 = doc.getElementsByClassName("hotness-signal red")(1).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "D").End(xlUp).Row + 1, "D").Value = dd1
                    Cells.WrapText = False
            End If
            
        'Current price
            If doc.getElementsByClassName("prRange")(i) Is Nothing Then
                    dd = doc.getElementsByClassName("prRange")(0) '.innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "E").End(xlUp).Row + 1, "E").Value = "-"
                Else
                    dd = doc.getElementsByClassName("prRange")(0).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "E").End(xlUp).Row + 1, "E").Value = dd
            Cells.WrapText = False
            End If
            
        'Sub Title
                If doc.getElementsByClassName("lvsubtitle")(i) Is Nothing Then
                    dd = doc.getElementsByClassName("lvsubtitle")(0) '.innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "F").End(xlUp).Row + 1, "F").Value = "-"
                   dd1 = doc.getElementsByClassName("lvsubtitle")(1)
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "G").End(xlUp).Row + 1, "G").Value = "-"
                   dd2 = doc.getElementsByClassName("lvsubtitle")(2)
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "H").End(xlUp).Row + 1, "H").Value = "-"
                   dd3 = doc.getElementsByClassName("lvsubtitle")(3)
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "I").End(xlUp).Row + 1, "I").Value = "-"
                Else
                    dd = doc.getElementsByClassName("lvsubtitle")(0).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "F").End(xlUp).Row + 1, "F").Value = dd
                    dd1 = doc.getElementsByClassName("lvsubtitle")(1).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "G").End(xlUp).Row + 1, "G").Value = dd1
                    dd2 = doc.getElementsByClassName("lvsubtitle")(2).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "H").End(xlUp).Row + 1, "H").Value = dd2
                    dd3 = doc.getElementsByClassName("lvsubtitle")(3).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "I").End(xlUp).Row + 1, "I").Value = dd3
                    Cells.WrapText = False
                End If
                              
         'Previous Price
                If doc.getElementsByClassName("stk-thr")(i) Is Nothing Then
                    dd = doc.getElementsByClassName("prRange")(0) '.innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "J").End(xlUp).Row + 1, "J").Value = "-"
                Else
                    dd = doc.getElementsByClassName("stk-thr")(0).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "J").End(xlUp).Row + 1, "J").Value = dd
                    Cells.WrapText = False
                End If
    
        'Shipping
                If doc.getElementsByClassName("bfsp")(i) Is Nothing Then
                    dd = doc.getElementsByClassName("bfsp")(0) '.innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "K").End(xlUp).Row + 1, "K").Value = "-"
                    dd1 = doc.getElementsByClassName("bfsp")(1) '.innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "L").End(xlUp).Row + 1, "L").Value = "-"
                Else
                    dd = doc.getElementsByClassName("bfsp")(0).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "K").End(xlUp).Row + 1, "K").Value = dd
                    dd1 = doc.getElementsByClassName("bfsp")(1).innerText
                        Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "L").End(xlUp).Row + 1, "L").Value = dd
                    Cells.WrapText = False
                End If
  
  Next i ' Next I item

'   Close IE
  IE.Quit
    Set IE = Nothing
    Set HTMLDoc = Nothing
    Set nextPageElement = Nothing
    Set div = Nothing
    Set link = Nothing
MsgBox "All Done"
            
End Sub

Display More

Sharid · Mar 4th 2020

Please see attachedEbay Code Oz Grid.xlsm

Sharid · Mar 4th 2020

Hi

I am stuck on a bit of code and cannot get it to work any further, sometimes it half works, other times it give an error message that i can not work out why.

When the code does half work, if places the searched data into the FIRST blank CELL in a column, when it should place it across the row, so if no data is found then it should leave that cell in the column blank, or place the word "Nil" if it would make it easier to fix

I have attached a link for the workbook to be downloaded, the code in button 1 is the issue.

There are two sheets in the workbook, Sheet2 shows how the data should look.

I can take this no further as I lack the knowledge and skill to do it, i'm hoping someone can help.

Thanks for have a look.

Download workbook

Sharid · May 25th 2019

Hi

This is my first post in a long time and the forum has changed a bit, so hopfully I have submitted it correctly, I need a bit of help on my code. I am very limited in excel VBA The code works fine, apart from -

I need it to extract ONLY emails and URLs and place the email in Sheet1 "Scraper" in the NEXT BLANK ROW

Currently it extracts anything text, emails or URL and places them in column A or B. I only need Emails or URLs. I have been stuck on this for sometime and can't seem to work it out

Also

I am not sure if my DELETE DUPLICATES is deleting duplicate rows or duplicates in column. It SHOULD ONLY delete duplicate rows

How the code works -

On Sheet2 "URL List" I have a list of URLs, the code runs through this and places the results onto Sheet1 "Scraper". and deletes any duplicates. My code is only supposed to scraper email and URLs and place them in Column A + B in the NEXT BLANK ROW.

I have tried to fix the problem but it is out of my scope. i am hoping someone can help

The code is below the. As stated above the code works fine apart from the code in RED, this is what the problem most likley is. The orange code is the delete options which may also be incorrect as DUPLICATE ROWS should be deleted and not Duplicate values in cells.

This is a FACEBOOK SCRAPER and scrapes the "about " pages urls here is a link https://www.facebook.com/pg/SalemFor...rnal%5Blink%5D

Code

Private Sub fbStart_Click()
[COLOR=#008000]'Set sheet2 URL List and open Internet Explorer[/COLOR]
    Dim lr          As Long
    Dim x           As Long
    Dim arr()       As Variant
    Dim wks         As Worksheet
    Dim ie          As Object
    Dim dd(1 To 2)  As String
    Dim Fr          As Long
    
    On Error Resume Next
    Application.ScreenUpdating = False
        
    Set wks = ThisWorkbook.Sheets("Url List")
    With wks
        Fr = .Cells(.Rows.Count, 6).End(xlUp).Offset(1).Row
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Cells(1, 5).Value = lr
        arr = .Range(.Cells(Fr, 1), .Cells(lr, 1)).Value
    End With
        
    [COLOR=#008000]'Show Internet Explorer and add delay in seconds if needed[/COLOR]
    Set ie = CreateObject("InternetExplorer.Application")
    With ie
        .Visible = True
        Application.Wait Now + TimeValue("0:00:0")
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            .navigate arr(x, 1)
            wtime = Time
            Do While .Busy Or .readyState <> 4
                DoEvents
                
    [COLOR=#008000]        'Skip pages with Captchas  + write the word Captcha in Sheet 2 Column C[/COLOR]
                If Time > (wtime + TimeValue("00:00:10")) Then
                    Cells(x + 1, "C").Value = "Captcha"
                    Exit Do
                End If
            Loop
            
            On Error Resume Next
           [COLOR=#008000] 'Variable for document or data which need to be extracted out of webpage, change innertext number if same class used[/COLOR]
            Dim doc As HTMLDocument
            Set doc = ie.document
         [COLOR=#FF0000]   dd(1) = doc.getElementsByClassName("_50f4")(2).innerText
            dd(2) = doc.getElementsByClassName("_50f4")(3).innerText
            [/COLOR]
           
           [COLOR=#008000] 'Paste the web data into Sheet1 "Scraper" in next BLANK ROW[/COLOR]
            With Sheet1
            [COLOR=#FF0000]    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(, 2).Value = dd[/COLOR]
            End With
            
           [COLOR=#008000] ' Put A number 1 in Sheet2 "Url List"column B to notify this URL is done[/COLOR]
            Sheets("Url List").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = 1
            
         [COLOR=#008000]    'Deletes duplicates in column A Sheet1[/COLOR]
       [COLOR=#FF8C00]     Columns(1).RemoveDuplicates Columns:=Array(1)
            Columns(2).RemoveDuplicates Columns:=Array(1)[/COLOR]
            
           [COLOR=#008000]  'Count No1 in sheet2 Column B[/COLOR]
            With Worksheets("Url List")
                Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
                Sheets("Url List").Range("B1").Value = Lastrow
            End With
            Call Autoclick_Click
        Next x
       .Quit
    End With
    
   [COLOR=#008000] 'Hide FaceBook Scraper Form[/COLOR]
    ScraperForm.Hide
   
End Sub

Display More

Thanks

Sharid · Jan 26th 2018

[SIZE=14px]Hi

I have a Command Button on Sheet1 and a List of URL in Sheet2 Column A. When the command button is clicked my code takes the first URL from Sheet2 Column A, opens IE and then imports the URL from that page into Sheet1 Column A, then closes IE and deletes any duplicates, this bit is fine . I can't get it to do this : -

1) I need the code to repeat but this time go to the next url in Sheet2 and do the same, the code does this until no more URL are left on Sheet2

2) It pastes the new date in the next blank row, currently it over writes the previous data.

[CODE[/SIZE]Private Sub CommandButton2_Click()

'For url extraction
Dim ie, items, elem As Object
Dim i, j, k, l As Integer

i = 2
k = 2
l = 2

'Create IE, open it for limited time, get url from sheet
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.Navigate Sheets("Sheet2").Range("A1").Value
Application.Wait (Now + TimeValue("00:00:5"))

Do While ie.Busy Or ie.ReadyState <> 4

Loop

For i = 0 To 500
On Error Resume Next

'Paste in sheet and column
Sheets("Sheet1").Range("A" & i).Value = ie.document.getelementsbytagname("a").Item(i).innerText

'Close IE Browser
Next i
ie.Visible = Quit

'Deletes duplicates in column A
Columns(1).RemoveDuplicates Columns:=Array(1)

End Sub[SIZE=14px]][/CODE]

I've been stuck on this for weeks, this is the best i can do. can some please help

Thanks[/SIZE]

Sharid · Sep 8th 2016

Re: Listbox Rowsource Not Populating Correctly

No you will need to make changes to the code, you can either put 2 list boxes or keep 1 and move all the data to 1 sheet.

Sharid · Aug 26th 2016

Re: ListBox move data to Dormant

Ok I have put together this code, which copies to dormant and deletes the data in the listbox and the listbox data source sheet, which is Sheet5 (Products)

The code works fine for the most part.

Copy and paste is fine, so the first bit of the code is ok.

The problem is in the second bit.

If i move 1 item at a time to dormant not including the last item in the list box everything is fine,

If i move only the last item to dormant, it deletes everything in the list box and sheet5 (product) and has only copied and pasted the last item to dormant.

can someone have alook at the last bit, THANKS

Code

Private Sub CommandButton7_Click()
'Copy to dormant
Dim i As Long, j As Long
    For i = 0 To Me.ListBox1.ListCount - 1
        If Me.ListBox1.Selected(i) Then
            j = j + 1
            Worksheets("Products").Range("A" & i + 2).Resize(1, 6).Copy Worksheets("Dormant").Range("A" & Rows.Count).End(xlUp).Offset(1)
        End If
    Next i
    MsgBox j & " Data has been moved to dormant"
    
 'REMOVE SELECTION
    With ListBox1
      For i = .ListCount - 1 To 0 Step -1
       If .Selected(i) Then
           .RemoveItem i
           Sheets("Products").Rows(i + 2).EntireRow.Delete
        End If
      Next i
      End With
End Sub

Display More

Sharid · Aug 26th 2016

I have a userform called ProductList, with 1 ListBox and a Dormant Button, when the form opens it populates from data on sheet5 (Products) I can't work out a code so when the user selects a item in the listbox and clicks on the dormant button. It will copy and pastes that information to sheet6 (Dormant) and remove that data from the listbox and Sheet5(Products),

e.g
Userform ProductList opens and is populated from Sheet5 (Products)

User select data in ListBox1

User clicks on the Dormant button

The item that was selected in Listbox1 is now copied and pasted into a Sheet6 (Dormant) in next blank row

THEN

The selected data from Listbox1 is removed from listbox1 and Sheet5 (Products) and any blank rows removed Sheet is auto saved, So the next time the user opens the ProductList userform and Listbox1 is populated from Sheet5 (Products) the removed data is no longer showing.

The data is on sheet5 (Products) Column A to R it will need to copy and past into Sheet6 (Dormant) Column A to R next blank row.

Sharid · Aug 26th 2016

Re: Listbox Rowsource Not Populating Correctly

This should also work, might need to change it a bit

Code

Private Sub UserForm_Initialize()
'Shows product list ROW from sheet to userform listbox1


ListBox1.ColumnCount = 3
    ListBox1.List = Range("A1:C" & Range("A" & Rows.Count).End(xlUp).Row).Value
    
'Shows product list COLUMN from sheet to userform listbox1
    Dim ws As Worksheet
    Dim rng As Range
    Dim i As Long, j As Long, rw As Long
    Dim Myarray() As String
     
     '~~> Change your sheetname here
    Set ws = Sheets("Emails")
     
     '~~> Set you relevant range here
    Set rng = ws.Range("A1").CurrentRegion
     
    With Me.ListBox1
        .Clear
        .ColumnHeads = False
        .ColumnCount = rng.Columns.Count
         .List = rng.Offset(1).Resize(rng.Rows.Count - 1, rng.Columns.Count).Value
        '.List = rng.Value
         
         '~~> Set the widths of the column here. Ex: For 5 Columns
         '~~> Change as Applicable
        .ColumnWidths = "50;175;60"
        .TopIndex = 0
         
         
    End With
     
     
End Sub

Display More

Sharid · Aug 24th 2016

Re: Clear data in row after date in row is 3 days old

This will clear data and keep fomula, you will have to run it every 3 days, could not send an IF statement. "If less than 3 days from today then run the code"

Code

Private Sub CommandButton3_Click()


On Error Resume Next
  ' clears data leave formula
  
Dim rConstants As Range


'Change your sheet name and range
Set rConstants = Sheet1.Range("F5:Z50").SpecialCells(xlCellTypeConstants)
    rConstants.ClearContents


End Sub

Display More

[CODESheet1.Range("F5:Z50")][/CODE] This reffers to Sheet1 range Column F Row 5 the next bit is Z50 the Z = upto column Z and 50 rows down. Yours will look like something like this.

Code

Set rConstants = Sheet1.Range("F5:Z6000").SpecialCells(xlCellTypeConstants)

Sheet.Range("F5: Then the last column with data in it from row F5 or the longest row with data in it up to 6000 as you have requested. I have used Column Z yours will differ.

TEST ON ANOTEHR WORKSHEET, BEFORE USING IT

Sharid · Aug 24th 2016

Re: Conditional Format Macro

Your code ammended

This is your problem .Color = 65535

Code

Sub CondFormat_Var() 
    Sheets("Variance").Select 
    With Range("E2:E45") 
        .FormatConditions.Add Type:=xlTextString, String:= _ 
        "Bad Debts Provision", TextOperator:=xlContains 
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority 
        With Selection.FormatConditions(1).Interior 
            .PatternColorIndex = xlAutomatic 
            .Color = 10
            .TintAndShade = 0 
        End With 
    End With 
     
     
End Sub

Display More

or you could go with mine

Sharid · Aug 24th 2016

Re: Conditional Format Macro

sorry forgot to put it in a code tag

[hr]*[/hr]
It would have been less bother to EDIT your post and add them rather than just adding a new reply saying you did forget them...

Sharid · Aug 24th 2016

Re: Conditional Format Macro

Code

Private Sub CommandButton1_Click()
'Change your sheet name
    Sheets("Data").Select
       lRow = Range("C" & Rows.Count).End(xlUp).Row
       'Set Your range
Set MR = Range("E2:E45" & lRow)
For Each cell In MR
'Cell color
    If cell.Value = "Bad Debts Provision" Then cell.Interior.ColorIndex = 10
        Next
End Sub

Display More

Sharid · Aug 24th 2016

Re: List Box range issue.

royUK

Sorry a bit long
Thanks for your code, but I'm still having the same problem. The changes are shown on the listbox but the spreadsheet is not updating so when the form loads again the old data is showing in the list box.

I have 2 userforms

First UserForm
On this userform (ProductList) I have a ListBox (ListBox1) and an edit button.

When the user selects the item in the listbox and then clicks on the edit button my second userform opens up, the second user form is called EditProductForm.

Second userform.
On this userform (EditProductList) I have 2 textboxes and a submit button. When this form opens the textboxes are populated with the selected data from listbox1 on the first userform. I have another code that does this
There is NO LISTBOX on the second userform.

This bit is fine
+ The second userform is populated from the selected data from userform one ListBox1, this bit is fine
+ When the submit button is clicked, the listbox1 on the first userform (ProductList) is updated, this bit is fine

This is the problem
Spreadsheet5 (Products) is not updated when the submit button is clicked on the second userform (EditProductList), therefore when the first userform reloads (ProductList), The ListBox reverts back to the old data as there are no updates to the spreadsheet.Also I need the data to replace the old one and not create a new entry, as the data is being editied not created new.

Sharid · Aug 23rd 2016

Re: Copy same range from certain worksheets and paste to one sheet

This might help, two methods

1st Method: -
Copies from a range and then pastes it to sheet1, first 4 lines, first bit of code copies from sheet 2 and pastes into first 4 rows of sheet1, the second bit of code copies from sheet3 and pastes into Sheet1 A5 the next 4 rows. If you go with this method, then you will need to do this for all your sheets. e.g sheet4 will paste into Sheet1 A9.
I have set the copy range of 4 rows from the other sheets, yours will differ

Code

Private Sub CommandButton1_Click()


'Copies range from sheet2 to sheet1
Worksheets("Sheet2").Range("A1:P4").Copy _
    Destination:=Worksheets("Sheet1").Range("A1")


'Copies range from sheet3 and pastes in sheet1 A5
   Worksheets("Sheet3").Range("A1:P4").Copy _
    Destination:=Worksheets("Sheet1").Range("A5")
End Sub

Display More

2nd Method:-

Second method is the same apart from it finds the next blank row to paste into for Sheet1, if your data has to be in some order i.e sheet 10 data is shown before the data of sheet3 has been copied and pasted then the code will look like the one in the last bit of code. As this is how the code will excute.

Code

Private Sub CommandButton1_Click()
'Copies range from sheet2 to sheet1 NEXT BLANK ROW
Worksheets("Sheet2").Range("A1:P4").Copy _
    Destination:=Worksheets("Sheet1").Range("A65536").End(xlUp).Offset(1)
  
'Copies range from sheet3 and pastes in sheet1 NEXT BLANK ROW
   Worksheets("Sheet3").Range("A1:P4").Copy _
    Destination:=Worksheets("Sheet1").Range("A65536").End(xlUp).Offset(1)
End Sub

This bit is info only

Code

Private Sub CommandButton1_Click()
'Copies range from sheet2 to sheet1 NEXT BLANK ROW
Worksheets("Sheet2").Range("A1:P4").Copy _
    Destination:=Worksheets("Sheet1").Range("A65536").End(xlUp).Offset(1)
  
'[B]Copies range from sheet10 and pastes in sheet1 NEXT BLANK ROW
   Worksheets("Sheet10").Range("A1:P4").Copy _
    Destination:=Worksheets("Sheet1").Range("A65536").End(xlUp).Offset(1)
End Sub[/B]


'Copies range from [B]sheet3[/B] and pastes in sheet1 NEXT BLANK ROW
   Worksheets("[B]Sheet3[/B]").Range("A1:P4").Copy _
    Destination:=Worksheets("Sheet1").Range("A65536").End(xlUp).Offset(1)
End Sub

Display More

hope this helps

Sharid · Aug 23rd 2016

Re: Listbox issue, data is removed

I've fixed the data vanishing issuefrom the listbox, I have placed the code in an IF statement and disabled the X button on second userform and placed a button with EditProductForm.Hide as the code and the issues has now gone.

The code below does what i want, it pulls the data from LISTBOX1 and in to the second userform called EditProductForm . On this user form I have two buttons, Submit and Close, the X button is now disabled.

My problem now is I can't save the changes to Sheet5 (Products)

The changes show within the listbox ASAP when i click submit, however the changes are not saving to the above sheet. So when the form reloads the changes are gone as the sheet has not been updated.

The code below is only for the edit button on a diffrent form called ProductList . The submit button is on EditProductForm

Code

Private Sub ListEditTB_Click() 'edit button


'Yes/No Message Box
Dim YesOrNoAnswerToMessageBox As String
Dim QuestionToMessageBox As String


    QuestionToMessageBox = "Are you sure you want to edit this products?"


    YesOrNoAnswerToMessageBox = MsgBox(QuestionToMessageBox, vbYesNo, "Add New Products")


If YesOrNoAnswerToMessageBox = vbYes Then


'Loadsform with data
Load EditProductForm
    With EditProductForm
        .EditProductTB.Text = ListBox1.List(ListBox1.ListIndex, 1)
        .EditUnitCostTB.Text = ListBox1.List(ListBox1.ListIndex, 2)
        .Show
    End With


     '// changes the listitem text
    ListBox1.List(ListBox1.ListIndex, 1) = EditProductForm.EditProductTB.Text
    ListBox1.List(ListBox1.ListIndex, 2) = EditProductForm.EditUnitCostTB.Text


    End If
End Sub

Display More

The code

Sharid · Aug 23rd 2016

The code below shows the information selected from my ListBox1, once the user selects the item and click the edit button, the EditProductForm LOADS with the selected data from Listbox1. This bit is fine.

The problem I have is if the user has selected the wrong Item and then closes the EditProductForm the selected data is removed from my listBox, which should not happen. It is still on my sheet and on next load of the listbox it re-shows. I can't figure this out

Code

Private Sub ListEditTB_Click() 'edit button
 Load EditProductForm
    With EditProductForm
        .EditProductTB.Text = ListBox1.List(ListBox1.ListIndex, 1)
        .EditUnitCostTB.Text = ListBox1.List(ListBox1.ListIndex, 2)
        .Show
    End With
    
     '// changes the listitem text
    ListBox1.List(ListBox1.ListIndex, 1) = EditProductForm.EditProductTB.Text
    ListBox1.List(ListBox1.ListIndex, 2) = EditProductForm.EditUnitCostTB.Text
End Sub

Display More

Also On the EditProductForm I have a submit button which will be used to submit the changes, my currect code for my submit button creates a new record of the submitted item, when it should replace the selected data as it has been edited. help on either one will be appreciated.

Sharid · Aug 23rd 2016

Re: List Box range issue.

Thanks this works.

Sharid · Aug 23rd 2016

I use this code to populate my listbox, with data from the sheet call Products, the code work fine, it does what i want apart from on thing, the range.
My range will vary depending on how many products are in the range. I set the range to ("A2:C65536") so it will include all products in the two columns.The problem I have is that it now shows all the rows including the blank ones in the list box, these don't need to show as they are empty, the scroll bar appears when it is not need.

The range will need to vary depending on the amount of products in the columns on the sheet. Can some please have a look. Thanks

Code

Private Sub UserForm_Initialize()


'Shows product list COLUMN from sheet to userform listbox1
Dim ws As Worksheet
    Dim rng As Range
    Dim i As Long, j As Long, rw As Long
    Dim Myarray() As String


    '~~> Change your sheetname here
    Set ws = Sheets("Products")


    '~~> Set you relevant range here
    Set rng = ws.Range("A2:C65536")


    With Me.ListBox1
        .Clear
        .ColumnHeads = False
        .ColumnCount = rng.Columns.Count


        ReDim Myarray(rng.Rows.Count, rng.Columns.Count)


        rw = 0


        For i = 1 To rng.Rows.Count
            For j = 0 To rng.Columns.Count
                Myarray(rw, j) = rng.Cells(i, j + 1)
            Next
            rw = rw + 1
        Next


        .List = Myarray


        '~~> Set the widths of the column here. Ex: For 5 Columns
        '~~> Change as Applicable
        .ColumnWidths = "50;175;60"
        .TopIndex = 0
        
        'Enable edit button turn to False
            ListEditTB.Enabled = False
    End With
End Sub

Display More

Posts by Sharid

Need help on writing a LOOP

Stuck on some code, extracting from HTML

Stuck on some code, extracting from HTML

Web Scraping

Extract Web Page URL inmport to Excel

Listbox Rowsource Not Populating Correctly

ListBox move data to Dormant

ListBox move data to Dormant

Listbox Rowsource Not Populating Correctly

Clear data in row after date in row is 3 days old

Conditional Format Macro

Conditional Format Macro

Conditional Format Macro

List Box range issue.

Copy same range from certain worksheets and paste to one sheet

Listbox issue, data is removed

Listbox issue, data is removed

List Box range issue.

List Box range issue.