using vba to clean up data

padadof2 · Apr 23, 2021

I have to clean up data and I'm hoping some excel Guru's can help me out. I get data has everything in one cell, separated by spaces, and I'd like to get it into a proper formatting, having one word per cell, but there's a caveat. Every even row, I need all that text in one cell

Here is the data I get in a single cell:



0696-0600 J1 Each 2.0000 N
TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2
0697-0600 J1 Each 2.0000 N
RESET TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2
0802-0001 C1, M Cubic Yard 99.0000 N
TOPSOIL FURNISHED AND PLACED
0867-0012 M2 Linear Foot 170.0000 N
COMPOST FILTER SOCK, 12" DIAMETER
0901-0001 Q Lump Sum 1.0000 N
MAINTENANCE AND PROTECTION OF TRAFFIC DURING CONSTRUCTION
0855-0003 M2 Each 1.0000 N
PUMPED WATER FILTER BAG
0855-0004 M2 Each 1.0000 N
REPLACEMENT PUMPED WATER FILTER BAG

Here is what I would like the vba to do:



0696-0600	TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2	2	Each
0697-0600	RESET TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2	2	Each
0802-0001	TOPSOIL FURNISHED AND PLACED	99	Cubic Yard
0867-0012	COMPOST FILTER SOCK, 12" DIAMETER	170	Linear Foot
0901-0001	MAINTENANCE AND PROTECTION OF TRAFFIC DURING CONSTRUCTION	1	Lump Sum
0855-0003	PUMPED WATER FILTER BAG	1	Each
0855-0004	REPLACEMENT PUMPED WATER FILTER BAG	1	Each

This is what I've come up with so far:

VBA Code:

Sub pdtest()
Dim MyArray() As String, MyString As String, I As Variant, N As Integer, r As Integer, lr As Integer

    lr = Cells(Rows.Count, 1).End(xlUp).Row
    I = 2
        For r = 1 To lr Step 2
            Cells(r, 1).Select
            MyString = ActiveCell.Value

            MyArray = Split(MyString, " ")

            For N = 0 To UBound(MyArray)
                Cells(lr + 1, N + 1).Value = MyArray(N)
            Next N
            
            Cells(lr + 1, 2).Value = Cells(I, 1).Value
            I = I + 2
    lr = lr + 1
Next r
End Sub

Hopefully some guru's are willing to help

rpaulson · Apr 23, 2021

try this.

create a new sheet named "Sheet2"

VBA Code:

Sub pdtest()

Dim rs As Worksheet
Set rs = Worksheets("Sheet2")
rs.Cells.ClearContents

    lr = Cells(Rows.Count, "A").End(xlUp).Row
     wr = 1
    
        For r = 1 To lr Step 2
        
           rs.Cells(wr, "A") = Split(Cells(r, "A"), " ")(0) 'item
           rs.Cells(wr, "C") = Split(Cells(r, "A"), " ")(3) 'qty
           rs.Cells(wr, "D") = Split(Cells(r, "A"), " ")(2) 'u/m
           
           rs.Cells(wr, "b") = Cells(r + 1, "A")
    wr = wr + 1

Next r
End Sub

hth,
Ross

johnnyL · Apr 23, 2021

rpaulson said:

try this.

create a new sheet named "Sheet2"

VBA Code:

Sub pdtest()

Dim rs As Worksheet
Set rs = Worksheets("Sheet2")
rs.Cells.ClearContents

    lr = Cells(Rows.Count, "A").End(xlUp).Row
     wr = 1
   
        For r = 1 To lr Step 2
       
           rs.Cells(wr, "A") = Split(Cells(r, "A"), " ")(0) 'item
           rs.Cells(wr, "C") = Split(Cells(r, "A"), " ")(3) 'qty
           rs.Cells(wr, "D") = Split(Cells(r, "A"), " ")(2) 'u/m
          
           rs.Cells(wr, "b") = Cells(r + 1, "A")
    wr = wr + 1

Next r
End Sub

hth,
Ross

Not quite.

Fluff · Apr 24, 2021

How about

VBA Code:

Sub padadof()
   Dim NxtRw As Long, y As Long
   Dim Tmp As Variant
   Dim Cl As Range
   
   With Sheets("Sheet1")
      .Range("C:F").ClearContents
      For Each Cl In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
         If Cl.Row Mod 2 = 1 Then
            NxtRw = NxtRw + 1
            .Range("C" & NxtRw).Value = Split(Cl.Value, " ")(0)
            Tmp = Split(StrReverse(Cl.Value), " ", 3)
            .Range("E" & NxtRw) = StrReverse(Tmp(1))
            Tmp = StrReverse(Tmp(2))
            y = Len(Tmp) - Len(Replace(Tmp, " ", ""))
            If y = 2 Then
               .Range("F" & NxtRw) = Split(Tmp, " ")(2)
            Else
               .Range("F" & NxtRw) = Split(Tmp, " ", y)(y - 1)
            End If
         Else
            .Range("D" & NxtRw) = Cl.Value
         End If
      Next Cl
   End With
End Sub

Fluff · Apr 24, 2021

Possibly more robust depending on your data.

VBA Code:

Sub padadof2()
   Dim NxtRw As Long
   Dim Tmp As Variant
   Dim Cl As Range
 
   With Sheets("Sheet1")
      .Range("C:F").ClearContents
      For Each Cl In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
         If Cl.Row Mod 2 = 1 Then
            NxtRw = NxtRw + 1
            .Range("C" & NxtRw).Value = Split(Cl.Value)(0)
            Tmp = Split(StrReverse(Cl.Value), , 3)
            .Range("E" & NxtRw) = StrReverse(Tmp(1))
            Tmp = StrReverse(Tmp(2))
            If Len(Split(Tmp)(2)) > 2 Then
               .Range("F" & NxtRw) = Split(Tmp, , 3)(2)
            Else
               .Range("F" & NxtRw) = Split(Tmp, , 4)(3)
            End If
         Else
            .Range("D" & NxtRw) = Cl.Value
         End If
      Next Cl
   End With
End Sub

+Fluff 1.xlsm

A

1

0696-0600 J1, M Each 2.0000 N

2

TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2

3

0697-0600 J1 Each 2.0000 N

4

RESET TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2

5

0802-0001 C1, M Cubic Yard 99.0000 N

6

TOPSOIL FURNISHED AND PLACED

7

0867-0012 M2 Linear Foot 170.0000 N

8

COMPOST FILTER SOCK, 12" DIAMETER

9

0901-0001 Q Lump Sum 1.0000 N

10

MAINTENANCE AND PROTECTION OF TRAFFIC DURING CONSTRUCTION

11

0855-0003 M2 Boxed in 10s 1.0000 N

12

PUMPED WATER FILTER BAG

13

0855-0004 M2 Each 1.0000 N

14

REPLACEMENT PUMPED WATER FILTER BAG

15

Main

+Fluff 1.xlsm

C

D

E

F

1

0696-0600

TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2

2

Each

2

0697-0600

RESET TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2

2

Each

3

0802-0001

TOPSOIL FURNISHED AND PLACED

99

Cubic Yard

4

0867-0012

COMPOST FILTER SOCK, 12" DIAMETER

170

Linear Foot

5

0901-0001

MAINTENANCE AND PROTECTION OF TRAFFIC DURING CONSTRUCTION

1

Lump Sum

6

0855-0003

PUMPED WATER FILTER BAG

1

Boxed in 10s

7

0855-0004

REPLACEMENT PUMPED WATER FILTER BAG

1

Each

8

Main

padadof2 · Apr 26, 2021

thank you guys, I really appreciate the help. Unfortunately I am not able to get fluffys code to work on this snippet of data.



1090-1018 S2 Square Foot 113.0000 N
PRESTRESSED CONCRETE BEAM REPAIRS
9000-0502 C1, S4 Cubic Foot 225.0000 N
INTRUSION GROUT BAGS
9000-0504 X Lump Sum 1.0000 N
WATER TESTING TECHNICIAN
9000-9001 S2 Cubic Foot 4.0000 N
REPAIR DETERIORATED CONCRETE

I'm not sure why but this is what I get

array testing with penndot items.xlsm

C

D

E

F

1

1090-1018

PRESTRESSED CONCRETE BEAM REPAIRS

113

Square Foot

2

9000-0502

INTRUSION GROUT BAGS

N

Cubic Foot 225.0000

3

9000-0504

WATER TESTING TECHNICIAN

1

Lump Sum

4

9000-9001

REPAIR DETERIORATED CONCRETE

N

Cubic Foot 4.0000

Sheet4 (4)

It looks like the tmp string changes, but I'm not savvy enough to know for sure why

***EDIT I had extra space in two of the cells, which was causing the issue. Thank you Fluffy, This works amazing!

Fluff · Apr 26, 2021

You have trailing spaces in some of those cells, try

VBA Code:

Sub padadof2()
   Dim NxtRw As Long
   Dim Tmp As Variant
   Dim Cl As Range
   
   With Sheets("main")
      .Range("C:F").ClearContents
      For Each Cl In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
         If Cl.Row Mod 2 = 1 Then
            NxtRw = NxtRw + 1
            .Range("C" & NxtRw).Value = Split(Trim(Cl.Value))(0)
            Tmp = Split(StrReverse(Trim(Cl.Value)), , 3)
            .Range("E" & NxtRw) = StrReverse(Tmp(1))
            Tmp = StrReverse(Tmp(2))
            If Len(Split(Tmp)(2)) > 2 Then
               .Range("F" & NxtRw) = Split(Tmp, , 3)(2)
            Else
               .Range("F" & NxtRw) = Split(Tmp, , 4)(3)
            End If
         Else
            .Range("D" & NxtRw) = Cl.Value
         End If
      Next Cl
   End With
End Sub

padadof2 · Apr 26, 2021

Fluff said:

You have trailing spaces in some of those cells, try

VBA Code:

Sub padadof2()
   Dim NxtRw As Long
   Dim Tmp As Variant
   Dim Cl As Range
  
   With Sheets("main")
      .Range("C:F").ClearContents
      For Each Cl In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
         If Cl.Row Mod 2 = 1 Then
            NxtRw = NxtRw + 1
            .Range("C" & NxtRw).Value = Split(Trim(Cl.Value))(0)
            Tmp = Split(StrReverse(Trim(Cl.Value)), , 3)
            .Range("E" & NxtRw) = StrReverse(Tmp(1))
            Tmp = StrReverse(Tmp(2))
            If Len(Split(Tmp)(2)) > 2 Then
               .Range("F" & NxtRw) = Split(Tmp, , 3)(2)
            Else
               .Range("F" & NxtRw) = Split(Tmp, , 4)(3)
            End If
         Else
            .Range("D" & NxtRw) = Cl.Value
         End If
      Next Cl
   End With
End Sub

yes, I just caught that as well. thank you again for your help!

Fluff · Apr 26, 2021

Glad we could help & thanks for the feedback.

padadof2 · Apr 30, 2021

Fluff, Can we revisit this code? It looks like there may be another string or two of text at the end of the odd lines at times which throw things off. Thanks again for your time

Book1

A

B

C

D

E

F

G

1

0605-2644 K Each 1.0000 N

0605-2644

Type D Endwall For 30" Pipe

1

EA

2

TYPE D ENDWALL FOR 30" PIPE

4605-2700

Inlet Grate Leafless

N

Each 20.0000

3

4605-2700 K Each 20.0000 N Std

0605-2730

Type M Concrete Top Unit And Grate

4

Set

4

INLET GRATE LEAFLESS

4605-2850

Standard Inlet Box, Height < /= 10' Includes Pipe Stubs

N

Each 3.0000

5

0605-2730 K Set 4.0000 N

4605-4010

Remove Existing Inlet

N

Each 2.0000

6

TYPE M CONCRETE TOP UNIT AND GRATE

4605-4011

Remove Existing Endwall

N

Each 7.0000

7

4605-2850 K Each 3.0000 N Proj

0608-0001

Mobilization

1

Lump Sum 1.0000 N

8

STANDARD INLET BOX, HEIGHT < /= 10' INCLUDES PIPE STUBS

0609-0002

Inspector's Field Office And Inspection Facilities, Type A

1

LS

9

4605-4010 C1, H Each 2.0000 N Std

0609-0009

Equipment Package

N

Lump Sum 1.0000

10

REMOVE EXISTING INLET

0610-7001

4" Pavement Base Drain

168

LF

11

4605-4011 C1, H Each 7.0000 N Std

0616-0009

Steel End Section, Metallic Coated, 16 Gage For 18" Pipe

2

EA

12

REMOVE EXISTING ENDWALL

13

0608-0001 X Lump Sum 1.0000 N 1 Added

14

MOBILIZATION

15

0609-0002 X Lump Sum 1.0000 N

16

INSPECTOR'S FIELD OFFICE AND INSPECTION FACILITIES, TYPE A

17

0609-0009 X Lump Sum 1.0000 N Std

18

EQUIPMENT PACKAGE

19

0610-7001 H2 Linear Foot 168.0000 N

20

4" PAVEMENT BASE DRAIN

21

0616-0009 H Each 2.0000 N

22

STEEL END SECTION, METALLIC COATED, 16 GAGE FOR 18" PIPE

Sheet1

using vba to clean up data

padadof2

New Member

Excel Facts

rpaulson

Well-known Member

johnnyL

Well-known Member

Attachments

Fluff

MrExcel MVP, Moderator

Fluff

MrExcel MVP, Moderator

padadof2

New Member

Fluff

MrExcel MVP, Moderator

padadof2

New Member

Fluff

MrExcel MVP, Moderator

padadof2

New Member

Forum statistics

Share this page

using vba to clean up data

New Member

Excel Facts

Well-known Member

Well-known Member

Attachments

MrExcel MVP, Moderator

MrExcel MVP, Moderator

New Member

MrExcel MVP, Moderator

New Member

MrExcel MVP, Moderator

New Member

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock