VBA and data layout

K

KaTa

New Member
Joined
May 5, 2022
Messages
15
Office Version
  1. 2011
Platform
  1. Windows
Hello!

At the moment I'm doing manual work to get desired data format. All this formatting is done in one sheet, Sheet1.

First I group cells by Header1 and then copy/paste to get needed format.
In desired data format line between Header4 different values.

Is it possible to do this all with VBA?

Table.xlsx
ABCDEFGH
1raw data format from A1
2Header1Header2Header3Header4Header5Header6Header7Header8
3x1234567
4x1235678
5x12489710
6y126101188
7y1271213814
8z121014151213
9z12816171412
10z12818191114
11
12
13
14Desired data format from A1
15Header1Header2Header3
16x12
17Header4Header5Header6Header7Header8Header8
18345678
19356789
204897108
21
22
23Header1Header2Header3
24y12
25Header4Header5Header6Header7Header8Header8
26610118813
277121381415
28
29
30Header1Header2Header3
31z12
32Header4Header5Header6Header7Header8Header8
33101415121311
3481617141213
3581819111415
36
37
Leht1
 

Attachments

  • table.jpg
    table.jpg
    71.4 KB · Views: 13

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
Try the following macro. Your data on sheet1, the results on sheet2.

VBA Code: 
Sub Format_Data_1()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim cell As Range
  Dim dic As Object
  Dim ky As Variant
  Dim lr As Long, lr2 As Long
  
  Application.ScreenUpdating = False
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  For Each cell In sh1.Range("A2:A" & lr)
    dic(cell.Value) = cell.Value & "|" & cell.Offset(, 1).Value & "|" & cell.Offset(, 2).Value
  Next
  
  sh2.Range("A:E").ClearContents
  lr2 = 1
  For Each ky In dic.Keys
    sh1.Range("A1:H" & lr).AutoFilter 1, ky
    sh2.Range("A" & lr2).Resize(1, 3).Value = sh1.Range("A1:C1").Value
    sh2.Range("A" & lr2 + 1).Resize(1, 3).Value = Split(dic(ky), "|")
    sh2.Range("A" & lr2 + 2).Resize(1, 5).Value = sh1.Range("D1:H1").Value
    sh1.AutoFilter.Range.Range("D2:H" & lr).Copy sh2.Range("A" & lr2 + 3)
    lr2 = sh2.Range("A" & Rows.Count).End(3).Row + 3
  Next ky
  sh1.ShowAllData
  Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Solution
DanteAmor said:
Try the following macro. Your data on sheet1, the results on sheet2.

VBA Code: 
Sub Format_Data_1()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim cell As Range
  Dim dic As Object
  Dim ky As Variant
  Dim lr As Long, lr2 As Long
 
  Application.ScreenUpdating = False
 
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  For Each cell In sh1.Range("A2:A" & lr)
    dic(cell.Value) = cell.Value & "|" & cell.Offset(, 1).Value & "|" & cell.Offset(, 2).Value
  Next
 
  sh2.Range("A:E").ClearContents
  lr2 = 1
  For Each ky In dic.Keys
    sh1.Range("A1:H" & lr).AutoFilter 1, ky
    sh2.Range("A" & lr2).Resize(1, 3).Value = sh1.Range("A1:C1").Value
    sh2.Range("A" & lr2 + 1).Resize(1, 3).Value = Split(dic(ky), "|")
    sh2.Range("A" & lr2 + 2).Resize(1, 5).Value = sh1.Range("D1:H1").Value
    sh1.AutoFilter.Range.Range("D2:H" & lr).Copy sh2.Range("A" & lr2 + 3)
    lr2 = sh2.Range("A" & Rows.Count).End(3).Row + 3
  Next ky
  sh1.ShowAllData
  Application.ScreenUpdating = True
End Sub
Click to expand...
Awesome!
Thank you DanteAmor
 
Upvote 0
Hi DanteAmor,
is it possible to do this data formatting all on sheet 1?

And an additional question about borders and header fonts.
All cells with values must have borders.
Header 1-3 and values: Font 14 and Bold
Header 4-8 line: Font 12 and bold.
Header 4: if the value changes then double line.

Thank You in advance!
 
Upvote 0
KaTa said:
All cells with values must have borders.
Header 1-3 and values: Font 14 and Bold
Header 4-8 line: Font 12 and bold.
Header 4: if the value changes then double line.
Click to expand...

Try this:

VBA Code: 
Sub Format_Data_1()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim cell As Range
  Dim dic As Object
  Dim ky As Variant, ant As Variant
  Dim i As Long, lr As Long, lr2 As Long
  
  Application.ScreenUpdating = False
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  For Each cell In sh1.Range("A2:A" & lr)
    dic(cell.Value) = cell.Value & "|" & cell.Offset(, 1).Value & "|" & cell.Offset(, 2).Value
  Next
  
  sh2.Range("A:E").Clear
  lr2 = 1
  For Each ky In dic.Keys
    sh1.Range("A1:H" & lr).AutoFilter 1, ky
    With sh2.Range("A" & lr2).Resize(1, 3)
      .Value = sh1.Range("A1:C1").Value
      .Borders.LineStyle = xlContinuous
      .Font.Bold = True
      .Font.Size = 14
      .HorizontalAlignment = xlCenter
    End With
    
    With sh2.Range("A" & lr2 + 1).Resize(1, 3)
      .Value = Split(dic(ky), "|")
      .Borders.LineStyle = xlContinuous
      .Font.Bold = True
      .Font.Size = 12
      .HorizontalAlignment = xlCenter
    End With
    
    With sh2.Range("A" & lr2 + 2).Resize(1, 5)
      .Value = sh1.Range("D1:H1").Value
      .Borders.LineStyle = xlContinuous
    End With
    
    sh1.AutoFilter.Range.Range("D2:H" & lr).Copy sh2.Range("A" & lr2 + 3)
    
    ant = sh2.Range("A" & lr2 + 3).Value
    For i = lr2 + 3 To sh2.Range("A" & Rows.Count).End(3).Row
      If ant <> sh2.Range("A" & i).Value Then
        sh2.Range("A" & i).Resize(1, 5).Borders(xlEdgeTop).LineStyle = xlDouble
      End If
      ant = sh2.Range("A" & i).Value
    Next
    
    lr2 = sh2.Range("A" & Rows.Count).End(3).Row + 3
  Next ky
  sh1.ShowAllData
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
DanteAmor said:
Try this:

VBA Code: 
Sub Format_Data_1()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim cell As Range
  Dim dic As Object
  Dim ky As Variant, ant As Variant
  Dim i As Long, lr As Long, lr2 As Long
 
  Application.ScreenUpdating = False
 
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  For Each cell In sh1.Range("A2:A" & lr)
    dic(cell.Value) = cell.Value & "|" & cell.Offset(, 1).Value & "|" & cell.Offset(, 2).Value
  Next
 
  sh2.Range("A:E").Clear
  lr2 = 1
  For Each ky In dic.Keys
    sh1.Range("A1:H" & lr).AutoFilter 1, ky
    With sh2.Range("A" & lr2).Resize(1, 3)
      .Value = sh1.Range("A1:C1").Value
      .Borders.LineStyle = xlContinuous
      .Font.Bold = True
      .Font.Size = 14
      .HorizontalAlignment = xlCenter
    End With
   
    With sh2.Range("A" & lr2 + 1).Resize(1, 3)
      .Value = Split(dic(ky), "|")
      .Borders.LineStyle = xlContinuous
      .Font.Bold = True
      .Font.Size = 12
      .HorizontalAlignment = xlCenter
    End With
   
    With sh2.Range("A" & lr2 + 2).Resize(1, 5)
      .Value = sh1.Range("D1:H1").Value
      .Borders.LineStyle = xlContinuous
    End With
   
    sh1.AutoFilter.Range.Range("D2:H" & lr).Copy sh2.Range("A" & lr2 + 3)
   
    ant = sh2.Range("A" & lr2 + 3).Value
    For i = lr2 + 3 To sh2.Range("A" & Rows.Count).End(3).Row
      If ant <> sh2.Range("A" & i).Value Then
        sh2.Range("A" & i).Resize(1, 5).Borders(xlEdgeTop).LineStyle = xlDouble
      End If
      ant = sh2.Range("A" & i).Value
    Next
   
    lr2 = sh2.Range("A" & Rows.Count).End(3).Row + 3
  Next ky
  sh1.ShowAllData
  Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you again! What do I need to change if I need xlDouble depending on the value changes in the Header7?
 
Upvote 0
KaTa said:
Instead of 4
Click to expand...

Rich (BB code): 
    ant = sh2.Range("D" & lr2 + 3).Value
    For i = lr2 + 3 To sh2.Range("D" & Rows.Count).End(3).Row
      If ant <> sh2.Range("D" & i).Value Then
        sh2.Range("A" & i).Resize(1, 5).Borders(xlEdgeTop).LineStyle = xlDouble
      End If
      ant = sh2.Range("D" & i).Value
    Next
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Question Question
Formatting raw data with extra rows automatically added in-between records
Replies
1
Views
55
Peter_SSs
Peter_SSs
Y
  • Question Question
VBA to copy, format, drag down data from other workbooks
Replies
1
Views
465
Yna26
Y
S
  • Question Question
VBA code to determine InDesign Layout
Replies
6
Views
445
Akuini
Akuini
D
  • Solved
How to control formatting of unprotected cells in a protected sheet? Ideas?
Replies
2
Views
344
Dman333
D
FrumpyJones
  • Question Question
Is there a way to stop COPY/PASTE but still allow manual entries and use of drop down lists.
Replies
5
Views
254
FrumpyJones
FrumpyJones

Forum statistics

Threads
1,223,911
Messages
6,175,324
Members
452,635
Latest member
laura12345

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