Extract data to another sheet layout

Goalexcel

Goalexcel

Board Regular
Joined
Dec 28, 2020
Messages
101
Office Version
  1. 2016
Platform
  1. Windows
Hello Expert. Please kindly help to find out the best way ,maybe with VBA to extract data to another sheet layout report .
DataSheet1 no always has the same range A21 to N Layoutsheet2.PNGDatasheet1.PNG

Below the link to check the excel file Mar Pav sent you 1 item
 
Sort by date Sort by votes
maabadi said:
Step 2 means add 2 to i value for each next round. if you don't write Step it means step 1
Also we can you is with step -1 when we want to go from end of range to top of range (specially when we delete rows and row numbers decreased).
Click to expand...
Hello @maabadi , can you kindly explain I need to repeat the rows, how to change the macro.


VBA Code: 
Sub TransformData2()
Dim i As Long, j As Long, Lr1 As Long, Arr As Variant, F As Long, Lr2 As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet, Nval As Variant
Set Sh1 = Sheets("Data")
Set Sh2 = Sheets("Layout")
'Set MyRange = Sh1.Range("A20:J24")
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlUp).Row




Sh2.Cells((i + 1) * 6 / 2 + 3, 1).Value = "SP"
Sh2.Cells((i + 1) * 6 / 2 + 3, 3).Value = "DECK"
Sh2.Cells((i + 1) * 6 / 2 + 3, 6).Value = "SP"
Sh2.Cells((i + 1) * 6 / 2 + 3, 8).Value = "DECK"


 i = 1
 
Sh2.Cells((i + 1) * 4 / 2 + 2, 2).Value = Sh1.Cells(20, i) 'Header B6
Sh2.Cells((i + 1) * 4 / 2 + 2, 7).Value = Sh1.Cells(20, i + 1) 'header G6


Sh2.Cells((i + 1) * 5 / 2 + 2, 1).Value = Sh1.Cells(21, i)
Sh2.Cells((i + 1) * 6 / 2 + 2, 1).Value = Sh1.Cells(22, i)
Sh2.Cells((i + 1) * 7 / 2 + 2, 1).Value = Sh1.Cells(23, i)
Sh2.Cells((i + 1) * 8 / 2 + 2, 1).Value = Sh1.Cells(24, i)


Sh2.Cells((i + 1) * 5 / 2 + 2, 6).Value = Sh1.Cells(21, i + 1)
Sh2.Cells((i + 1) * 6 / 2 + 2, 6).Value = Sh1.Cells(22, i + 1)
Sh2.Cells((i + 1) * 7 / 2 + 2, 6).Value = Sh1.Cells(23, i + 1)
Sh2.Cells((i + 1) * 8 / 2 + 2, 6).Value = Sh1.Cells(24, i + 1)


For i = 3 To 10 Step 2


Sh2.Cells((i + 1) * 6 / 2, 2).Value = Sh1.Cells(20, i)
Sh2.Cells((i + 1) * 6 / 2, 7).Value = Sh1.Cells(20, i + 1)


Sh2.Cells((i + 1) * 5 / 2 + 3, 1).Value = Sh1.Cells(21, i)
Sh2.Cells((i + 1) * 5 / 2 + 4, 1).Value = Sh1.Cells(22, i)
Sh2.Cells((i + 1) * 5 / 2 + 5, 1).Value = Sh1.Cells(23, i)
Sh2.Cells((i + 1) * 5 / 2 + 6, 1).Value = Sh1.Cells(24, i)




Sh2.Cells((i + 1) * 5 / 2 + 3, 6).Value = Sh1.Cells(21, i + 1)
Sh2.Cells((i + 1) * 5 / 2 + 4, 6).Value = Sh1.Cells(22, i + 1)
Sh2.Cells((i + 1) * 5 / 2 + 5, 6).Value = Sh1.Cells(23, i + 1)
Sh2.Cells((i + 1) * 5 / 2 + 6, 6).Value = Sh1.Cells(24, i + 1)






Next i


End Sub
 
Upvote 0

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Goalexcel said:
can you kindly explain I need to repeat the rows, how to change the macro.
Click to expand...
Please tell with more details. you want repeat rows for what. or when repeat rows, you want replaced previous data or at the other columns.
 
Upvote 0
I already modified the code, copy 4 numbers in another sheet. The code needs to apply in many sheets from sheet 1 until sheet10 count to end
Sheet1 copy to track2, sheet3 copy track4. Each sheet has a different name.
Also need to add a code that clear previous number in sheet name track & number., see below image that need to clear contents the numbers only
The code is

VBA Code: 
Sub TransformData()

Dim i As Long, j As Long, Lr1 As Long, Arr As Variant, F As Long, Lr2 As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet, Nval As Variant
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
'Set MyRange = Sh1.Range("A20:J24")
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To 10 Step 2

Sh2.Cells((i + 1) * 6 / 2, 1).Value = "SP"
Sh2.Cells((i + 1) * 6 / 2, 3).Value = "DECK"
Sh2.Cells((i + 1) * 6 / 2, 6).Value = "SP"
Sh2.Cells((i + 1) * 6 / 2, 8).Value = "DECK"
 
Sh2.Cells((i + 1) * 6 / 2, 2).Value = Sh1.Cells(20, i) 'Header B6
Sh2.Cells((i + 1) * 6 / 2, 7).Value = Sh1.Cells(20, i + 1) 'header G6

Sh2.Cells((i + 1) * 6 / 2 + 1, 1).Value = Sh1.Cells(21, i)
Sh2.Cells((i + 1) * 6 / 2 + 2, 1).Value = Sh1.Cells(22, i)
Sh2.Cells((i + 1) * 6 / 2 + 3, 1).Value = Sh1.Cells(23, i)
Sh2.Cells((i + 1) * 6 / 2 + 4, 1).Value = Sh1.Cells(24, i)


Sh2.Cells((i + 1) * 6 / 2 + 1, 6).Value = Sh1.Cells(21, i + 1)
Sh2.Cells((i + 1) * 6 / 2 + 2, 6).Value = Sh1.Cells(22, i + 1)
Sh2.Cells((i + 1) * 6 / 2 + 3, 6).Value = Sh1.Cells(23, i + 1)
Sh2.Cells((i + 1) * 6 / 2 + 4, 6).Value = Sh1.Cells(24, i + 1)

Next i

End Sub


The result is
1637823888930.png
 
Upvote 0
Sorry for dely on reply.
I didn't understand your result take from where, because I don't see your source data, Please upload your example data with desired result at minimum 2 sheets.
 
Upvote 0
maabadi said:
Sorry for dely on reply.
I didn't understand your result take from where, because I don't see your source data, Please upload your example data with desired result at minimum 2 sheets.
Click to expand...
Please kindly here find the example file

www.dropbox.com

Transfer - Dropbox

Dropbox is a free service that lets you bring your photos, docs, and videos anywhere and share them easily. Never email yourself a file again!
www.dropbox.com www.dropbox.com
 
Upvote 0
Try this:
VBA Code: 
Sub TransformData()

Dim i As Long, j As Long, Lr1 As Long, Arr As Variant, F As Long, Lr2 As Long

For j = 1 To Sheets.Count Step 2
Lr1 = Sheets(j).Cells(Rows.Count, 1).End(xlUp).Row
' if you want more you can change 10 to number of Data group added to each sheet
For i = 1 To 10 Step 2

Sheets(j + 1).Cells((i + 1) * 6 / 2, 1).Value = "DATA"
Sheets(j + 1).Cells((i + 1) * 6 / 2, 3).Value = "DATA"
Sheets(j + 1).Cells((i + 1) * 6 / 2, 6).Value = "DATA"
Sheets(j + 1).Cells((i + 1) * 6 / 2, 8).Value = "DATA"
  
Sheets(j + 1).Cells((i + 1) * 6 / 2, 2).Value = Sheets(j).Cells(20, i) 'Header B6
Sheets(j + 1).Cells((i + 1) * 6 / 2, 7).Value = Sheets(j).Cells(20, i + 1) 'header G6

Sheets(j + 1).Cells((i + 1) * 6 / 2 + 1, 1).Value = Sheets(j).Cells(21, i)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 2, 1).Value = Sheets(j).Cells(22, i)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 3, 1).Value = Sheets(j).Cells(23, i)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 4, 1).Value = Sheets(j).Cells(24, i)


Sheets(j + 1).Cells((i + 1) * 6 / 2 + 1, 6).Value = Sheets(j).Cells(21, i + 1)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 2, 6).Value = Sheets(j).Cells(22, i + 1)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 3, 6).Value = Sheets(j).Cells(23, i + 1)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 4, 6).Value = Sheets(j).Cells(24, i + 1)

Next i
Next j

End Sub
 
Upvote 0
maabadi said:
Try this:
VBA Code: 
Sub TransformData()

Dim i As Long, j As Long, Lr1 As Long, Arr As Variant, F As Long, Lr2 As Long

For j = 1 To Sheets.Count Step 2
Lr1 = Sheets(j).Cells(Rows.Count, 1).End(xlUp).Row
' if you want more you can change 10 to number of Data group added to each sheet
For i = 1 To 10 Step 2

Sheets(j + 1).Cells((i + 1) * 6 / 2, 1).Value = "DATA"
Sheets(j + 1).Cells((i + 1) * 6 / 2, 3).Value = "DATA"
Sheets(j + 1).Cells((i + 1) * 6 / 2, 6).Value = "DATA"
Sheets(j + 1).Cells((i + 1) * 6 / 2, 8).Value = "DATA"
 
Sheets(j + 1).Cells((i + 1) * 6 / 2, 2).Value = Sheets(j).Cells(20, i) 'Header B6
Sheets(j + 1).Cells((i + 1) * 6 / 2, 7).Value = Sheets(j).Cells(20, i + 1) 'header G6

Sheets(j + 1).Cells((i + 1) * 6 / 2 + 1, 1).Value = Sheets(j).Cells(21, i)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 2, 1).Value = Sheets(j).Cells(22, i)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 3, 1).Value = Sheets(j).Cells(23, i)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 4, 1).Value = Sheets(j).Cells(24, i)


Sheets(j + 1).Cells((i + 1) * 6 / 2 + 1, 6).Value = Sheets(j).Cells(21, i + 1)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 2, 6).Value = Sheets(j).Cells(22, i + 1)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 3, 6).Value = Sheets(j).Cells(23, i + 1)
Sheets(j + 1).Cells((i + 1) * 6 / 2 + 4, 6).Value = Sheets(j).Cells(24, i + 1)

Next i
Next j

End Sub
Click to expand...
Thank you @maabadi, please add a line to make clear previous contents with the numbers only, because when I run for second time the code still the
previous data or numbers.
 
Upvote 0
Try this:
VBA Code: 
Sub TransformData()

Dim i As Long, j As Long, Lr1 As Long, K As Long, F As Long, Lr2 As Long

For j = 1 To Sheets.Count Step 2
Lr1 = Sheets(j).Cells(Rows.Count, 1).End(xlUp).Row
' if you want more you can change 10 to number of Data group added to each sheet
For i = 1 To 10 Step 2
K = (i + 1) * 6 / 2
Sheets(j + 1).Cells(K, 1).Value = "DATA"
Sheets(j + 1).Cells(K, 3).Value = "DATA"
Sheets(j + 1).Cells(K, 6).Value = "DATA"
Sheets(j + 1).Cells(K, 8).Value = "DATA"
  
Sheets(j + 1).Cells(K, 2).Value = Sheets(j).Cells(20, i) 'Header B6
Sheets(j + 1).Cells(K, 7).Value = Sheets(j).Cells(20, i + 1) 'header G6

Sheets(j + 1).Cells(K + 1).Resize(4).ClearContents
Sheets(j + 1).Cells(K + 1, 1).Value = Sheets(j).Cells(21, i)
Sheets(j + 1).Cells(K + 2, 1).Value = Sheets(j).Cells(22, i)
Sheets(j + 1).Cells(K + 3, 1).Value = Sheets(j).Cells(23, i)
Sheets(j + 1).Cells(K + 4, 1).Value = Sheets(j).Cells(24, i)

Sheets(j + 1).Cells(K + 1, 6).Resize(4).ClearContents
Sheets(j + 1).Cells(K + 1, 6).Value = Sheets(j).Cells(21, i + 1)
Sheets(j + 1).Cells(K + 2, 6).Value = Sheets(j).Cells(22, i + 1)
Sheets(j + 1).Cells(K + 3, 6).Value = Sheets(j).Cells(23, i + 1)
Sheets(j + 1).Cells(K + 4, 6).Value = Sheets(j).Cells(24, i + 1)

Next i
Next j

End Sub
 
Upvote 0
Please check the code run error 1004, message we can't do that to a merged cell
 
Upvote 0
Sorry my fault. Try this:
VBA Code: 
Sub TransformData()

Dim i As Long, j As Long, Lr1 As Long, K As Long, F As Long, Lr2 As Long

For j = 1 To Sheets.Count Step 2
Lr1 = Sheets(j).Cells(Rows.Count, 1).End(xlUp).Row
' if you want more you can change 10 to number of Data group added to each sheet
For i = 1 To 10 Step 2
K = (i + 1) * 6 / 2
Sheets(j + 1).Cells(K, 1).Value = "DATA"
Sheets(j + 1).Cells(K, 3).Value = "DATA"
Sheets(j + 1).Cells(K, 6).Value = "DATA"
Sheets(j + 1).Cells(K, 8).Value = "DATA"
  
Sheets(j + 1).Cells(K, 2).Value = Sheets(j).Cells(20, i) 'Header B6
Sheets(j + 1).Cells(K, 7).Value = Sheets(j).Cells(20, i + 1) 'header G6

Sheets(j + 1).Cells(K + 1, 1).Resize(4).ClearContents
Sheets(j + 1).Cells(K + 1, 1).Value = Sheets(j).Cells(21, i)
Sheets(j + 1).Cells(K + 2, 1).Value = Sheets(j).Cells(22, i)
Sheets(j + 1).Cells(K + 3, 1).Value = Sheets(j).Cells(23, i)
Sheets(j + 1).Cells(K + 4, 1).Value = Sheets(j).Cells(24, i)

Sheets(j + 1).Cells(K + 1, 6).Resize(4).ClearContents
Sheets(j + 1).Cells(K + 1, 6).Value = Sheets(j).Cells(21, i + 1)
Sheets(j + 1).Cells(K + 2, 6).Value = Sheets(j).Cells(22, i + 1)
Sheets(j + 1).Cells(K + 3, 6).Value = Sheets(j).Cells(23, i + 1)
Sheets(j + 1).Cells(K + 4, 6).Value = Sheets(j).Cells(24, i + 1)

Next i
Next j

End Sub
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

A
  • Solved
VBA code to extract a table
Replies
5
Views
301
Anthony47
A
S
  • Question Question
VBA code to determine InDesign Layout
Replies
6
Views
525
Akuini
Akuini
S
  • Question Question
VBA : Reflection Workspace extract all screen/pages
Replies
0
Views
130
Samantha27
S
C
  • Question Question
VBA code stuck (extract data from worksheet)
Replies
1
Views
411
Alex Blakenburg
A
C
  • Question Question
How to automatically paste the data from one sheet to another using VBA
Replies
4
Views
292
Alex Blakenburg
A

Forum statistics

Threads
1,224,827
Messages
6,181,198
Members
453,022
Latest member
RobertV1609

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