rearranging columns by reversing in location and create headers

A

abdo meghari

Active Member
Joined
Aug 3, 2021
Messages
465
Office Version
  1. 2019
Hi guys,
I have untidy data in columns I:N .I would arranging again in columns A:E
column A=column N
column B=column L
column C=column K
column D=column J
column E=column I
and every number is merged in column N,K,J,I then should cancel merging as show in column A,C,D,E and at the same time should merge the cells are consecutive in column L as show in column B for the number is merged in column N
after that should delete all of columns from I:N
and should create headers in row1.


before
COL.xlsm
IJKLMN
1
22,700.00JAPANBRIDGESTONEBS 1200R20 18PR G580 1
3JAP
42,680.00JAPANBRIDGESTONEBS 1200R20 18PR R187 2
5JAP
62,550.00JAPANBRIDGESTONEBS 1200R24 G5803
72,600.00JAPANBRIDGESTONEBS 1200R24 G582 JAP4
84,160.00JAPANBRIDGESTONEBS 1400R20 TCF R180 5
9JAP
104,280.00JAPANBRIDGESTONEBS 1400R20VSJ TCF JAP6
11420THILANDBRIDGESTONEBS 175/65R14 EP1507
12180TURKEYBRIDGESTONEBS 175/70R13 EP150 82S 8
13TURK
14280THILANDBRIDGESTONEBS 175/70R13 EP150 THI9
15215THILANDBRIDGESTONEBS 175/70R14 MY02 THI10
16260IndonesiaBRIDGESTONEBS 185/65R14 EP150 11
17IND
18315JAPANBRIDGESTONEBS 185/65R15 B250 JAP12
19290IndonesiaBRIDGESTONEBS 185/70R13 EP150 13
20IND
21360THILANDBRIDGESTONEBS 185/70R14 B250 THI14
22435TURKEYBRIDGESTONEBS 185R14C R660 15
23102R100R 8 TURK
24288THILANDBRIDGESTONEBS 195/60R15 EP150 THI16
25267JAPANBRIDGESTONEBS 195/60R15 T001 JAP17
26335JAPANBRIDGESTONEBS 195/65R15 EP150 JAP18
27740JAPANBRIDGESTONEBS 195/70R15C R623 19
28JAP
29490THILANDBRIDGESTONEBS 195R14C R623 THI20
30488TURKEYBRIDGESTONEBS 195R14C R660 TURK21
31428JAPANBRIDGESTONEBS 195R15C 613V JAP22
32490THILANDBRIDGESTONEBS 195R15C R623 THI23
33490TURKEYBRIDGESTONEBS 195R15C R660 TURK24
34409TURKEYBRIDGESTONEBS 205/65R15 EP150 25
35TURK
36300THILANDBRIDGESTONEBS 205/65R15 T005 THI26
SS



result should be

COL.xlsm
ABCDEFGHIJKLMN
1ITEMBRANDMARKSORIGINPRICE
21BS 1200R20 18PR G580 JAPBRIDGESTONEJAPAN2,700.00
32BS 1200R20 18PR R187 JAPBRIDGESTONEJAPAN2,680.00
43BS 1200R24 G580BRIDGESTONEJAPAN2,550.00
54BS 1200R24 G582 JAPBRIDGESTONEJAPAN2,600.00
65BS 1400R20 TCF R180 JAPBRIDGESTONEJAPAN4,160.00
76BS 1400R20VSJ TCF JAPBRIDGESTONEJAPAN4,280.00
87BS 175/65R14 EP150BRIDGESTONETHILAND420.00
98BS 175/70R13 EP150 82S TURKBRIDGESTONETURKEY180.00
109BS 175/70R13 EP150 THIBRIDGESTONETHILAND280.00
1110BS 175/70R14 MY02 THIBRIDGESTONETHILAND215.00
1211BS 185/65R14 EP150 INDBRIDGESTONEIndonesia260.00
1312BS 185/65R15 B250 JAPBRIDGESTONEJAPAN315.00
1413BS 185/70R13 EP150 INDBRIDGESTONEIndonesia290.00
1514BS 185/70R14 B250 THIBRIDGESTONETHILAND360.00
1615BS 185R14C R660 102R100R 8 TURKBRIDGESTONETURKEY435.00
1716BS 195/60R15 EP150 THIBRIDGESTONETHILAND288.00
1817BS 195/60R15 T001 JAPBRIDGESTONEJAPAN267.00
1918BS 195/65R15 EP150 JAPBRIDGESTONEJAPAN335.00
2019BS 195/70R15C R623 JAPBRIDGESTONEJAPAN740.00
2120BS 195R14C R623 THIBRIDGESTONETHILAND490.00
2221BS 195R14C R660 TURKBRIDGESTONETURKEY488.00
2322BS 195R15C 613V JAPBRIDGESTONEJAPAN428.00
2423BS 195R15C R623 THIBRIDGESTONETHILAND490.00
2524BS 195R15C R660 TURKBRIDGESTONETURKEY490.00
2625BS 205/65R15 EP150 TURKBRIDGESTONETURKEY409.00
2726BS 205/65R15 T005 THIBRIDGESTONETHILAND300.00
SS
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sort by date Sort by votes
See if this works for you:

VBA Code: 
Sub RearrangeColumnsUnmergeRows()

    Dim sht As Worksheet
    Dim rngSrc As Range, rngDest As Range
    Dim rowLastSrc As Long
    Dim arrSrc As Variant, arrDest As Variant, arrHdg As Variant
    Dim iSrc As Long, iDest As Long
    
    Application.ScreenUpdating = False
    
    Set sht = ActiveSheet                               ' <--- Ideally replace this with Worksheets("NameOfSheet")
    
    With sht
        rowLastSrc = .Cells(Rows.Count, "L").End(xlUp).Row
        If rowLastSrc = .Cells(Rows.Count, "I").End(xlUp).Row Then
            rowLastSrc = rowLastSrc + 1                 ' The norm is 2 rows per item
        End If
        Set rngSrc = .Range("I2", .Cells(rowLastSrc, "N"))
        arrSrc = rngSrc.Value
        
        Set rngDest = .Range("a1")
        arrHdg = Array("Item", "BRAND", "MARKS", "ORIGIN", "PRICE")
    End With
    
    ReDim arrDest(1 To UBound(arrSrc, 1), 1 To UBound(arrSrc, 2) - 1)
    
    For iSrc = 1 To UBound(arrSrc)
        If arrSrc(iSrc, 1) <> "" Then
            iDest = iDest + 1
            arrDest(iDest, 1) = arrSrc(iSrc, 6)         ' N to A
            arrDest(iDest, 2) = arrSrc(iSrc, 4)         ' L to B
            arrDest(iDest, 3) = arrSrc(iSrc, 3)         ' K to C
            arrDest(iDest, 4) = arrSrc(iSrc, 2)         ' J to D
            arrDest(iDest, 5) = arrSrc(iSrc, 1)         ' I to E
        ElseIf arrSrc(iSrc, 4) <> "" Then
            arrDest(iDest, 2) = arrDest(iDest, 2) & " " & arrSrc(iSrc, 4)       ' Append L to previous value
        End If
    Next iSrc
    
    With rngDest
        ' Headings
        With .Resize(, UBound(arrHdg) + 1)
            .Range("I1").Copy
                .PasteSpecial Paste:=xlPasteFormats
            .WrapText = False
            .Value = arrHdg
        End With
        ' Data
        .Offset(1).Resize(iDest, UBound(arrDest, 2)).Value = arrDest
        rngSrc.EntireColumn.Delete
        .Resize(, UBound(arrHdg) + 1).EntireColumn.AutoFit
        .Rows(2).Resize(iDest).EntireRow.AutoFit
    End With
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Try:
VBA Code: 
Sub RearrangeColumns()
    Application.ScreenUpdating = False
    Dim lRow As Long, x As Long
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range("A1").Resize(, 5) = Array("ITEM", "BRAND", "MARKS", "ORIGIN", "PRICE")
    Range("A1").Resize(, 5).Interior.ColorIndex = Range("I1").Interior.ColorIndex
    ActiveSheet.Range("I2", Range("I" & Rows.Count).End(xlUp)).Resize(, 6).UnMerge
    For x = lRow To 2 Step -1
        If Range("K" & x) = "" Then
            Range("L" & x - 1) = Range("L" & x - 1) & " " & Range("L" & x)
            Rows(x).Delete
        End If
    Next x
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Range("A2").Resize(lRow - 1)
        .Value = Range("N2").Resize(lRow - 1).Value
        .Interior.ColorIndex = 1
        .Font.Color = vbWhite
    End With
    Range("B2").Resize(lRow - 1).Value = Range("L2").Resize(lRow - 1).Value
    Range("C2").Resize(lRow - 1).Value = Range("K2").Resize(lRow - 1).Value
    Range("D2").Resize(lRow - 1).Value = Range("J2").Resize(lRow - 1).Value
    Range("E2").Resize(lRow - 1).Value = Range("I2").Resize(lRow - 1).Value
    Range("I1").Resize(, 7).EntireColumn.Delete
    Range("A1").Resize(lRow).HorizontalAlignment = xlCenter
    Columns.AutoFit
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Great Guys!(y)
can fix borders & formatting,please?
I would create formatting & borders based on original data in I:N
I see your codes delete them if I do that manually .
thanks
 
Upvote 0
Try:
VBA Code: 
Sub RearrangeColumns()
    Application.ScreenUpdating = False
    Dim lRow As Long, x As Long
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range("A1").Resize(, 5) = Array("ITEM", "BRAND", "MARKS", "ORIGIN", "PRICE")
    Range("A1").Resize(, 5).Interior.ColorIndex = Range("I1").Interior.ColorIndex
    ActiveSheet.Range("I2", Range("I" & Rows.Count).End(xlUp)).Resize(, 6).UnMerge
    For x = lRow To 2 Step -1
        If Range("K" & x) = "" Then
            Range("L" & x - 1) = Range("L" & x - 1) & " " & Range("L" & x)
            Rows(x).Delete
        End If
    Next x
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Range("A2").Resize(lRow - 1)
        .Value = Range("N2").Resize(lRow - 1).Value
        .Interior.ColorIndex = 1
        .Font.Color = vbWhite
    End With
    Range("B2").Resize(lRow - 1).Value = Range("L2").Resize(lRow - 1).Value
    Range("C2").Resize(lRow - 1).Value = Range("K2").Resize(lRow - 1).Value
    Range("D2").Resize(lRow - 1).Value = Range("J2").Resize(lRow - 1).Value
    Range("E2").Resize(lRow - 1).Value = Range("I2").Resize(lRow - 1).Value
    Range("I1").Resize(, 7).EntireColumn.Delete
    With Range("A1").Resize(lRow, 5)
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .Font.Name = "Times"
        .Font.Size = 12
    End With
    Columns.AutoFit
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
abdo meghari said:
I would create formatting & borders based on original data in I:N
Click to expand...
There is very little formatting applied to the original columns and the border formatting it not coming through on the XL2BB.
I thought to just leave it with the latest post by @mumps, but since that involves deleting rows it might not be quick enough if you have a lot data. I am using an array which should be quicker. Unfortunately nowhere near as compact ;)

I have followed mumps's lead and just tried to match what you have in your results XL2BB.

VBA Code: 
Sub RearrangeColumnsUnmergeRows()

    Dim sht As Worksheet
    Dim rngSrc As Range, rngDest As Range
    Dim rowLastSrc As Long
    Dim arrSrc As Variant, arrDest As Variant, arrHdg As Variant
    Dim iSrc As Long, iDest As Long
    
    Application.ScreenUpdating = False
    
    Set sht = ActiveSheet                               ' <--- Ideally replace this with Worksheets("NameOfSheet")
    
    With sht
        rowLastSrc = .Cells(Rows.Count, "L").End(xlUp).Row
        If rowLastSrc = .Cells(Rows.Count, "I").End(xlUp).Row Then
            rowLastSrc = rowLastSrc + 1                 ' The norm is 2 rows per item
        End If
        Set rngSrc = .Range("I2", .Cells(rowLastSrc, "N"))
        arrSrc = rngSrc.Value
        
        Set rngDest = .Range("A1")
        arrHdg = Array("ITEM", "BRAND", "MARKS", "ORIGIN", "PRICE")
    End With
    
    ReDim arrDest(1 To UBound(arrSrc, 1), 1 To UBound(arrSrc, 2) - 1)
    
    For iSrc = 1 To UBound(arrSrc)
        If arrSrc(iSrc, 1) <> "" Then
            iDest = iDest + 1
            arrDest(iDest, 1) = arrSrc(iSrc, 6)         ' N to A
            arrDest(iDest, 2) = arrSrc(iSrc, 4)         ' L to B
            arrDest(iDest, 3) = arrSrc(iSrc, 3)         ' K to C
            arrDest(iDest, 4) = arrSrc(iSrc, 2)         ' J to D
            arrDest(iDest, 5) = arrSrc(iSrc, 1)         ' I to E
        ElseIf arrSrc(iSrc, 4) <> "" Then
            arrDest(iDest, 2) = arrDest(iDest, 2) & " " & arrSrc(iSrc, 4)       ' Append L to previous value
        End If
    Next iSrc
       
    ' Data Range
    With rngDest.Offset(1).Resize(iDest, UBound(arrDest, 2))
        .Value = arrDest
        
        ' Item No Column
        With .Columns(1)
            .Interior.Color = 6908265                   ' Set Fill to grey
            .Font.Color = vbWhite                       ' Set Font to white
        End With
        
        ' Price Column
        With Columns(UBound(arrDest, 2))
            .NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
        End With
    End With
    
    rngSrc.EntireColumn.Delete
    
    ' Whole output range
    Set rngDest = rngDest.Resize(iDest + 1, UBound(arrDest, 2))
    With rngDest
        ' Apply Formatting
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .Font.Name = "Times"
        
        ' Heading
        With .Rows(1)
            .Value = arrHdg
            .Interior.Color = 15570276          ' Set heading row fill to light blue
            .Font.Color = vbWhite               ' Set heading row font to white
            .Font.Bold = True
        End With
        
        ' Autofit Columns but toggle font size to provide additional white space
        .Font.Size = 14
        .EntireColumn.AutoFit
        .Font.Size = 12
        
        .Resize(iDest).EntireRow.AutoFit
    End With
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Solution
again guys I appreciated for your help
@Alex just curiosity if you don't mind as you know after running the macro will delete data in columns I:N and if I run the code again Unintentionally will shows
application defined error in this line
VBA Code: 
    With rngDest.Offset(1).Resize(iDest, UBound(arrDest, 2))
I try to understand your code and add message box to avoid error as bold , but doesn't work
Rich (BB code): 
' Data Range
   If IsEmpty(arrDest) Then MsgBox "no data": Exit Sub
    With rngDest.Offset(1).Resize(iDest, UBound(arrDest, 2))
I hope to help me to avoid error when data are empty in column I:N


@mumps the same error shows as I said to Alex but in this line
VBA Code: 
    With Range("A2").Resize(lRow - 1)
but after show error will delete data A:E. I would show message "no data" if there is no data in I:N and keep data in A:E
thanks in advance.
 
Upvote 0
Put this line of code at the very beginning of the macro:
Code: 
If Range(“I2”) <> “” Then
And this line of code at the very end:
Code: 
End If
 
Upvote 0
mumps said:
Put this line of code at the very beginning of the macro:
Code: 
If Range(“I2”) <> “” Then
Click to expand...
Just be aware that VBA does not like slanted/titled quotes. You need to use the straight ones, i.e.
VBA Code: 
If Range("I2") <> "" Then
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
replace item for range with item for Table based on column
2
Replies
13
Views
658
Legacy 143009
L
A
  • Solved
add specific character in the beginning of item into column
Replies
9
Views
433
Fluff
Fluff
A
  • Question
Highlight and delete duplicates items in the different spaces for multiple columns
Replies
1
Views
309
abdo meghari
A
A
  • Question
delete unmatched item for two sheets with another two sheets and put the similar to adjacent
Replies
1
Views
311
abdo meghari
A
A
  • Question
insert column to auto-number for each item into two sheets
Replies
0
Views
223
abdo meghari
A

Forum statistics

Threads
1,215,219
Messages
6,123,691
Members
449,117
Latest member
Aaagu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top