VBA: Extracting raw data and move into a new Sheet (tidy format)

[Chanzuihou]

Dear all,

I am very entry-level with VBA and am now desperately needing a set of VBA, for one of my repeating work task. Is possible that any of you VBA expert please help me with a set of VBA code please? Any help is sincerely appreciated.

In the below raw data, would like to move the following data across to Sheet "DATA_AF_VBA" (pls refer to below screen paste, the desired format). Data I would like to copy across is:
- Webshop
- Price
- Product

Really appreciate any advice. thanks heaps ~~~~

Raw data:

Excel 2012
	A	B	C	D	E	F	G	H
1	Price2Spy Tool - Daily notification e-mail
2	Price2Spy has detected price changes. Please see the list of the products below.
3	Product : CFX40W
4	Webshop	Price		Available	Last checked	Last change	Failed attempts	Last message error
5	12 Volt Technology	1,039.00 AUD
6		was: 1,079.00 AUD	?	Yes	1/04/2020 2:14	1/04/2019 0:00	0
7	seabreeze	1,099.00 AUD
8		was: 973.00 AUD	?	Yes	1/04/2020 2:14	1/04/2006 19:40	0
9	Tentworld	1,099.99 AUD
10		was: 973.00 AUD	?	Yes	1/04/2020 2:14	1/04/2004 20:57	0
11	Snowys	1,149.00 AUD
12		was: 1,039.00 AUD	?	Yes	1/04/2020 2:14	1/03/2008 15:41	0
13	Anacondastores	1,149.00 AUD
14		was: 1,039.20 AUD	? 10.57 %	Yes	1/04/2020 2:14	1/04/2020 2:14	0
15	My Generator	1,249.00 AUD
16		was: 1,079.00 AUD	?	Yes	1/04/2020 2:14	1/04/2019 0:00	0
17	BCF	1,299.00 AUD		Yes	1/04/2020 2:14	1/03/2007 15:14	0
18	Product : CFX50W
19	Webshop	Price		Available	Last checked	Last change	Failed attempts	Last message error
20	12 Volt Technology	1,159.00 AUD
21		was: 1,198.00 AUD	?	Yes	1/04/2020 2:14	1/04/2019 0:19	0
22	Tentworld	1,199.00 AUD
23		was: 1,085.00 AUD	?	Yes	1/04/2020 2:14	1/04/2004 20:18	0
24	seabreeze	1,199.00 AUD
25		was: 1,085.00 AUD	?	Yes	1/04/2020 2:14	1/04/2006 19:41	0
26	Snowys	1,249.00 AUD
27		was: 1,159.00 AUD	?	Yes	1/04/2020 2:14	1/03/2008 15:36	0
28	Anacondastores	1,299.00 AUD
29		was: 1,159.20 AUD	? 12.06 %	Yes	1/04/2020 2:14	1/04/2020 2:14	0
30	BCF	1,449.00 AUD		Yes	1/04/2020 2:14	1/03/2007 15:23	0
31	Rays Outdoors	1,449.00 AUD		Yes	1/04/2020 2:14	1/03/2007 15:23	0
32	Product : CFX65W
33	Webshop	Price		Available	Last checked	Last change	Failed attempts	Last message error
34	12 Volt Technology	1,279.00 AUD
35		was: 1,399.00 AUD	?	Yes	1/04/2020 1:27	1/04/2019 0:19	0
36	Tentworld	1,399.99 AUD
37		was: 1,198.00 AUD	?	Yes	1/04/2020 1:27	1/04/2004 20:39	0
38	Snowys	1,449.00 AUD
39		was: 1,279.00 AUD	?	Yes	1/04/2020 1:27	1/03/2008 15:59	1	There's been a problem while loading a page.
40	Anacondastores	1,449.00 AUD
41		was: 1,279.20 AUD	? 13.27 %	Yes	1/04/2020 1:27	1/04/2020 1:27	0
42	BCF	1,599.00 AUD		Yes	1/04/2020 1:27	1/03/2007 15:30	0
43	My Generator	1,599.00 AUD
44		was: 1,299.00 AUD	?	Yes	1/04/2020 1:27	1/04/2019 0:19	0
45	Product : CFX95DZW
46	Webshop	Price		Available	Last checked	Last change	Failed attempts	Last message error
47	12 Volt Technology	1,519.00 AUD
48		was: 1,699.00 AUD	?	Yes	1/04/2020 2:04	1/04/2019 0:00	0
49	Tentworld	1,699.00 AUD
50		was: 1,423.00 AUD	?	Yes	1/04/2020 2:04	1/04/2004 20:18	0
51	Snowys	1,749.00 AUD
52		was: 1,599.00 AUD	?	Yes	1/04/2020 2:04	1/03/2008 15:45	0
53	Anacondastores	1,749.00 AUD
54		was: 1,519.20 AUD	? 15.13 %	Yes	1/04/2020 2:04	1/04/2020 2:04	0
55	BCF	1,899.00 AUD		Yes	1/04/2020 2:04	1/03/2007 15:35	0
56	Rays Outdoors	1,899.00 AUD		Yes	1/04/2020 2:04	1/03/2007 15:37	0
57	My Generator	1,899.00 AUD
58		was: 1,649.00 AUD	?	Yes	1/04/2020 2:04	1/04/2019 0:00	0
59	seabreeze	1,569.00 AUD
60		was: 1,749.00 AUD	?	Yes	1/03/2025 20:00	1/03/2014 16:13	10	This Webshop is supported, but the URL you've entered is not a single product page.
0419

Desired format: using VBA to move raw data into the desired format:

Excel 2012
	A	B	C	D
1	Webshop	Price	Product	Date
2	12 Volt Technology	1,039.00	CFX40W	19/04/2017
3	seabreeze	1,099.00	CFX40W	19/04/2017
4	Tentworld	1,099.99	CFX40W	19/04/2017
5	Snowys	1,149.00	CFX40W	19/04/2017
6	Anacondastores	1,149.00	CFX40W	19/04/2017
7	My Generator	1,249.00	CFX40W	19/04/2017
8	BCF	1,299.00	CFX40W	19/04/2017
9	12 Volt Technology	1,159.00	CFX50W	19/04/2017
10	Tentworld	1,199.00	CFX50W	19/04/2017
11	seabreeze	1,199.00	CFX50W	19/04/2017
12	Snowys	1,249.00	CFX50W	19/04/2017
13	Anacondastores	1,299.00	CFX50W	19/04/2017
14	BCF	1,449.00	CFX50W	19/04/2017
15	Rays Outdoors	1,449.00	CFX50W	19/04/2017
16	12 Volt Technology	1,279.00	CFX65W	19/04/2017
17	Tentworld	1,399.99	CFX65W	19/04/2017
18	Snowys	1,449.00	CFX65W	19/04/2017
19	Anacondastores	1,449.00	CFX65W	19/04/2017
20	BCF	1,599.00	CFX65W	19/04/2017
21	My Generator	1,599.00	CFX65W	19/04/2017
22	12 Volt Technology	1,519.00	CFX95DZW	19/04/2017
23	Tentworld	1,699.00	CFX95DZW	19/04/2017
24	Snowys	1,749.00	CFX95DZW	19/04/2017
25	Anacondastores	1,749.00	CFX95DZW	19/04/2017
26	BCF	1,899.00	CFX95DZW	19/04/2017
27	Rays Outdoors	1,899.00	CFX95DZW	19/04/2017
28	My Generator	1,899.00	CFX95DZW	19/04/2017
29	seabreeze	1,569.00	CFX95DZW	19/04/2017
Data_AF_VBA

 

[gallen]

Re: VBA help pls~ Extracting raw data and move into a new Sheet (tidy format)

So the date in column D of the desired format is the date the sheet was generated ie Today's date?

 

[gallen]

Re: VBA help pls~ Extracting raw data and move into a new Sheet (tidy format)

This does as you ask but doesn't do any formatting. I'm guessing you'll be able to do that.

Place this code in the worksheet that has the raw data:

Sub GenerateSheet()


    Dim ws As Worksheet 'New worksheet to copy data to.
    Dim sCurrentProduct As String
    Dim lr As Long 'last row on column B as Column A has blanks
    Dim nr As Long 'next available row on new sheet
    Dim c As Range
    
    Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    'set column headers
    With ws
        .Name = "DATA_AF_VBA"
        .Cells(1, 1) = "Webshop"
        .Cells(1, 2) = "Price"
        .Cells(1, 3) = "Product"
        .Cells(1, 4) = "Date"
    End With
    
    lr = Range("B" & Rows.Count).End(xlUp).Row
    nr = 2
    
    'loop down column A extracting all information.
    
    For Each c In Range(Cells(3, 1).Address, Cells(lr, 1).Address)
        If Left(c, 7) = "Product" Then
            sCurrentProduct = Right(c, Len(c) - InStr(1, c, ":") - 1)
        ElseIf Trim(c) <> "Webshop" And Len(c) > 0 Then 'ignore cells with webshop in them and blank cells
            ws.Range("A" & nr) = c 'Webshop
            ws.Range("B" & nr) = c.Offset(0, 1) 'Price
            ws.Range("C" & nr) = sCurrentProduct 'Product
            ws.Range("D" & nr) = Format(Now, "dd/mm/yyyy")
            nr = nr + 1
        End If
    Next c
    
    'Do formatting here
    
End Sub

 

[Chanzuihou]

Re: VBA help pls~ Extracting raw data and move into a new Sheet (tidy format)

So the date in column D of the desired format is the date the sheet was generated ie Today's date?

Dear Gallen

Thanks, the date can be manually entered at later stage (no need to be part of VBA code), which yes it was the date the data was generated

Thanks heaps

 

[Chanzuihou]

Re: VBA help pls~ Extracting raw data and move into a new Sheet (tidy format)

Thanking you SO much Gallen, truly appreciate your help~~~~

 

[gallen]

Re: VBA help pls~ Extracting raw data and move into a new Sheet (tidy format)

No problem.

 

[Chanzuihou]

Re: VBA help pls~ Extracting raw data and move into a new Sheet (tidy format)

Dear gallen

Thanks again for your help. today I pasted the VBA code into the work sheet and ran. It successfully generated a sheet "DATA_AF_VBA", and in that sheet, it showed up header "Webshop", "Price", "Product" and "Date". So thank you.

However it stopped there and didn't extract any data into the newly generated sheet.

Do you mind to have a look? I was also wondering, if it is possible to make some implementation of the code, to achieve:
1. No need to create a new Sheet "DATA_AF_VBA", because this sheet would have already been created within the workbook.
2. Instead, would like to copy the desirable data ("Webshop", "Price" and "Product") to the already existing Sheet "DATA_AB_VBA".
3. In the already existing DATA_AT_VBA sheet, it already has headers of "Webshop", "Price" and "Product" and underneath each header, it will already have previous dates' information.
4. The extracted data can be pasted to the next available Blank cell, under the right Header, starting from column A. For example, in my example of raw data sheet, 12 Volt Technology is the first "Webshop"; it should be copied to sheet "DATA_AF_VBA" cell A2. Its "price" is 1,039.00 AUD, which ideally is pasted to B2; and the "product" is CFX40W, which should be copied to C2
5. Then the VBA code ideally loops to next Webshop etc etc.

Really appreciate any feedback or assistance.

Thanks again

 

[gallen]

Re: VBA help pls~ Extracting raw data and move into a new Sheet (tidy format)

I tested that on the exact raw data you provided and the results were exactly as the results you provided.

The only way that code won't work is if it isn't pasted into the sheet with the raw data.

This loop goes down every cell in column A of raw data. If it finds none-blank cell with a value that doesn't contain "Webshop" or "Product" it uses that value as the webshop:

    For Each c In Range(Cells(3, 1).Address, Cells(lr, 1).Address)
        If Left(c, 7) = "Product" Then
            sCurrentProduct = Right(c, Len(c) - InStr(1, c, ":") - 1)
[COLOR=#ff0000][B]        ElseIf Trim(c) <> "Webshop" And Len(c) > 0 Then 'ignore cells with webshop in them and blank cells[/B][/COLOR]
[B][COLOR=#ff0000]            ws.Range("A" & nr) = c 'Webshop[/COLOR][/B]
            ws.Range("B" & nr) = c.Offset(0, 1) 'Price
            ws.Range("C" & nr) = sCurrentProduct 'Product
            ws.Range("D" & nr) = Format(Now, "dd/mm/yyyy")
            nr = nr + 1
        End If
    Next c

Then the cell value to the right of the webshop name on the raw data sheet is copied to the cell to the right of the webshop name we pasted in the previous step:

    For Each c In Range(Cells(3, 1).Address, Cells(lr, 1).Address)
        If Left(c, 7) = "Product" Then
            sCurrentProduct = Right(c, Len(c) - InStr(1, c, ":") - 1)
        ElseIf Trim(c) <> "Webshop" And Len(c) > 0 Then 'ignore cells with webshop in them and blank cells
            ws.Range("A" & nr) = c 'Webshop
[COLOR=#ff0000][B]            ws.Range("B" & nr) = c.Offset(0, 1) 'Price[/B][/COLOR]
            ws.Range("C" & nr) = sCurrentProduct 'Product
            ws.Range("D" & nr) = Format(Now, "dd/mm/yyyy")
            nr = nr + 1
        End If

    Next c

Finally, the product is added using the variable we extracted when the loop comes to cell with the word "Product" in it.

    For Each c In Range(Cells(3, 1).Address, Cells(lr, 1).Address)
[COLOR=#ff0000][B]        If Left(c, 7) = "Product" Then[/B][/COLOR]
[COLOR=#ff0000][B]            sCurrentProduct = Right(c, Len(c) - InStr(1, c, ":") - 1)[/B][/COLOR]
        ElseIf Trim(c) <> "Webshop" And Len(c) > 0 Then 'ignore cells with webshop in them and blank cells
            ws.Range("A" & nr) = c 'Webshop
            ws.Range("B" & nr) = c.Offset(0, 1) 'Price
[B][COLOR=#ff0000]            ws.Range("C" & nr) = sCurrentProduct 'Product[/COLOR][/B]
            ws.Range("D" & nr) = Format(Now, "dd/mm/yyyy")
            nr = nr + 1
        End If

    Next c

So if the code isn't working the data is in the wrong place. Have you stepped through to see if the loop actually executes?

I won't address the additional requests until this issue is fixed. Once we know that works it's simple to change to what you want.

 

[Chanzuihou]

Re: VBA help pls~ Extracting raw data and move into a new Sheet (tidy format)

I tested that on the exact raw data you provided and the results were exactly as the results you provided.

The only way that code won't work is if it isn't pasted into the sheet with the raw data.

This loop goes down every cell in column A of raw data. If it finds none-blank cell with a value that doesn't contain "Webshop" or "Product" it uses that value as the webshop:

    For Each c In Range(Cells(3, 1).Address, Cells(lr, 1).Address)
        If Left(c, 7) = "Product" Then
            sCurrentProduct = Right(c, Len(c) - InStr(1, c, ":") - 1)
[COLOR=#ff0000][B]        ElseIf Trim(c) <> "Webshop" And Len(c) > 0 Then 'ignore cells with webshop in them and blank cells[/B][/COLOR]
[B][COLOR=#ff0000]            ws.Range("A" & nr) = c 'Webshop[/COLOR][/B]
            ws.Range("B" & nr) = c.Offset(0, 1) 'Price
            ws.Range("C" & nr) = sCurrentProduct 'Product
            ws.Range("D" & nr) = Format(Now, "dd/mm/yyyy")
            nr = nr + 1
        End If
    Next c

Then the cell value to the right of the webshop name on the raw data sheet is copied to the cell to the right of the webshop name we pasted in the previous step:

    For Each c In Range(Cells(3, 1).Address, Cells(lr, 1).Address)
        If Left(c, 7) = "Product" Then
            sCurrentProduct = Right(c, Len(c) - InStr(1, c, ":") - 1)
        ElseIf Trim(c) <> "Webshop" And Len(c) > 0 Then 'ignore cells with webshop in them and blank cells
            ws.Range("A" & nr) = c 'Webshop
[COLOR=#ff0000][B]            ws.Range("B" & nr) = c.Offset(0, 1) 'Price[/B][/COLOR]
            ws.Range("C" & nr) = sCurrentProduct 'Product
            ws.Range("D" & nr) = Format(Now, "dd/mm/yyyy")
            nr = nr + 1
        End If

    Next c

Finally, the product is added using the variable we extracted when the loop comes to cell with the word "Product" in it.

    For Each c In Range(Cells(3, 1).Address, Cells(lr, 1).Address)
[COLOR=#ff0000][B]        If Left(c, 7) = "Product" Then[/B][/COLOR]
[COLOR=#ff0000][B]            sCurrentProduct = Right(c, Len(c) - InStr(1, c, ":") - 1)[/B][/COLOR]
        ElseIf Trim(c) <> "Webshop" And Len(c) > 0 Then 'ignore cells with webshop in them and blank cells
            ws.Range("A" & nr) = c 'Webshop
            ws.Range("B" & nr) = c.Offset(0, 1) 'Price
[B][COLOR=#ff0000]            ws.Range("C" & nr) = sCurrentProduct 'Product[/COLOR][/B]
            ws.Range("D" & nr) = Format(Now, "dd/mm/yyyy")
            nr = nr + 1
        End If

    Next c

So if the code isn't working the data is in the wrong place. Have you stepped through to see if the loop actually executes?

I won't address the additional requests until this issue is fixed. Once we know that works it's simple to change to what you want.

Thank you so much Gallen, I will run this through when logging in shortly. Much Appreciate it

 

[Chanzuihou]

Re: VBA help pls~ Extracting raw data and move into a new Sheet (tidy format)

Dear gallen

Yes you are hundred percent correct, after I put the code into the raw data sheet, it works perfectly!!!!

Brilliant work and thanks again.

I tested that on the exact raw data you provided and the results were exactly as the results you provided.

The only way that code won't work is if it isn't pasted into the sheet with the raw data.

This loop goes down every cell in column A of raw data. If it finds none-blank cell with a value that doesn't contain "Webshop" or "Product" it uses that value as the webshop:

    For Each c In Range(Cells(3, 1).Address, Cells(lr, 1).Address)
        If Left(c, 7) = "Product" Then
            sCurrentProduct = Right(c, Len(c) - InStr(1, c, ":") - 1)
[COLOR=#ff0000][B]        ElseIf Trim(c) <> "Webshop" And Len(c) > 0 Then 'ignore cells with webshop in them and blank cells[/B][/COLOR]
[B][COLOR=#ff0000]            ws.Range("A" & nr) = c 'Webshop[/COLOR][/B]
            ws.Range("B" & nr) = c.Offset(0, 1) 'Price
            ws.Range("C" & nr) = sCurrentProduct 'Product
            ws.Range("D" & nr) = Format(Now, "dd/mm/yyyy")
            nr = nr + 1
        End If
    Next c

Then the cell value to the right of the webshop name on the raw data sheet is copied to the cell to the right of the webshop name we pasted in the previous step:

    For Each c In Range(Cells(3, 1).Address, Cells(lr, 1).Address)
        If Left(c, 7) = "Product" Then
            sCurrentProduct = Right(c, Len(c) - InStr(1, c, ":") - 1)
        ElseIf Trim(c) <> "Webshop" And Len(c) > 0 Then 'ignore cells with webshop in them and blank cells
            ws.Range("A" & nr) = c 'Webshop
[COLOR=#ff0000][B]            ws.Range("B" & nr) = c.Offset(0, 1) 'Price[/B][/COLOR]
            ws.Range("C" & nr) = sCurrentProduct 'Product
            ws.Range("D" & nr) = Format(Now, "dd/mm/yyyy")
            nr = nr + 1
        End If

    Next c

Finally, the product is added using the variable we extracted when the loop comes to cell with the word "Product" in it.

    For Each c In Range(Cells(3, 1).Address, Cells(lr, 1).Address)
[COLOR=#ff0000][B]        If Left(c, 7) = "Product" Then[/B][/COLOR]
[COLOR=#ff0000][B]            sCurrentProduct = Right(c, Len(c) - InStr(1, c, ":") - 1)[/B][/COLOR]
        ElseIf Trim(c) <> "Webshop" And Len(c) > 0 Then 'ignore cells with webshop in them and blank cells
            ws.Range("A" & nr) = c 'Webshop
            ws.Range("B" & nr) = c.Offset(0, 1) 'Price
[B][COLOR=#ff0000]            ws.Range("C" & nr) = sCurrentProduct 'Product[/COLOR][/B]
            ws.Range("D" & nr) = Format(Now, "dd/mm/yyyy")
            nr = nr + 1
        End If

    Next c

So if the code isn't working the data is in the wrong place. Have you stepped through to see if the loop actually executes?

I won't address the additional requests until this issue is fixed. Once we know that works it's simple to change to what you want.