Solved

how can change the attached excel format

Posted on 2016-07-17
9
75 Views
Last Modified: 2016-09-21
how can change the attached excel format from sheet1 to sheet2 with macro
Book1.xlsx
0
Comment
Question by:Mohammed Dallag
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 5
  • 4
9 Comments
 
LVL 31

Expert Comment

by:Subodh Tiwari (Neeraj)
ID: 41716374
Please try this...

In the attached, click the button "Extract Data" on the Output Sheet to get the desired output.


Sub ReArrangeData()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long, lc As Long, i As Long, dlr As Long
Dim rng As Range, cell As Range

Application.ScreenUpdating = False
Set sws = Sheets("Sheet1")
Set dws = Sheets("Output")

lr = sws.Cells(Rows.Count, 1).End(xlUp).Row
lc = sws.Cells(1, Columns.Count).End(xlToLeft).Column
Set rng = sws.Range("A4:A" & lr)

dlr = dws.Cells(Rows.Count, 1).End(xlUp).Row
If dlr > 1 Then dws.Range("A2:G" & dlr).Clear

For i = 2 To lc Step 5
   For Each cell In rng
      dlr = dws.Cells(Rows.Count, 1).End(xlUp).Row + 1
      dws.Range("A" & dlr) = sws.Cells(1, i)
      cell.Copy dws.Range("B" & dlr)
      sws.Cells(cell.Row, i).Resize(, 5).Copy dws.Range("C" & dlr)
   Next cell
Next i

dws.Columns.AutoFit
dws.Range("A1").CurrentRegion.Borders.Color = vbBlack
dws.Activate
Application.ScreenUpdating = True
End Sub

Open in new window

ReArrangeData.xlsm
0
 

Author Comment

by:Mohammed Dallag
ID: 41726576
I run this and it hang with more data. Please see the attached sheet.
Book3.xlsm
0
 
LVL 31

Expert Comment

by:Subodh Tiwari (Neeraj)
ID: 41726635
Please replace the existing code with the following one and let me know if that works for you considering the size of data on the sheet. It takes 24 seconds to process that much of data at my end.

Sub ReArrangeDataVersion2()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long, lc As Long, i As Long, dlr As Long
Dim x, y
Dim TimeTaken As Date
TimeTaken = Now
Application.ScreenUpdating = False
Set sws = Sheets("Sheet1")
Set dws = Sheets("Output")

lr = sws.Cells(Rows.Count, 1).End(xlUp).Row
lc = sws.Cells(1, Columns.Count).End(xlToLeft).Column

dlr = dws.Cells(Rows.Count, 2).End(xlUp).Row
If dlr > 1 Then dws.Range("A2:G" & dlr).Clear
y = sws.Range("A4:A" & lr).Value

For i = 2 To lc Step 5
   DoEvents
   dws.Range("B" & Rows.Count).End(3)(2).Offset(0, -1) = sws.Cells(1, i)
   dws.Range("B" & Rows.Count).End(3)(2).Resize(UBound(y, 1)).Value = y
   x = sws.Range(sws.Cells(4, i), sws.Cells(lr, i + 4)).Value
   dws.Range("C" & Rows.Count).End(3)(2).Resize(UBound(y, 1), 5).Value = x
Next i
dlr = dws.Cells(Rows.Count, 1).End(xlUp).Row
dws.Range("A2:A" & dlr).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
dws.Range("A2:A" & dlr).Value = dws.Range("A2:A" & dlr).Value
dws.Columns.AutoFit
dws.Range("A1").CurrentRegion.Borders.Color = vbBlack
dws.Activate
Application.ScreenUpdating = True
MsgBox "Time taken to process data was " & Format(Now - TimeTaken, "hh:mm:ss")
End Sub

Open in new window

0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:Mohammed Dallag
ID: 41726710
very good but the last well K 51 was written only once. Check the snapshot attached.
2016-07-24_22-47-38.jpg
0
 
LVL 31

Expert Comment

by:Subodh Tiwari (Neeraj)
ID: 41726943
My bad. Please replace the line#25 i.e.

dlr = dws.Cells(Rows.Count, 1).End(xlUp).Row

Open in new window


WITH THIS

dlr = dws.Cells(Rows.Count, 2).End(xlUp).Row

Open in new window

0
 

Author Comment

by:Mohammed Dallag
ID: 41755570
Dear Neeraj,

The data are not converted to the output sheet right. Please check the data for well MAGO-14. Please check the attached file.

Regards,

Dallag
ReArrangeData_V31_dummy-data.xlsm
0
 
LVL 31

Accepted Solution

by:
Subodh Tiwari (Neeraj) earned 500 total points
ID: 41756043
Hi Dallag,

Please try the following code and let me know if that works for you.


Sub ReArrangeDataVersion3()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long, lc As Long, i As Long, dlr As Long
Dim x, y
Dim TimeTaken As Date
TimeTaken = Now
Application.ScreenUpdating = False
Set sws = Sheets("Sheet1")
Set dws = Sheets("Output")

lr = sws.Cells(Rows.Count, 1).End(xlUp).Row
lc = sws.Cells(1, Columns.Count).End(xlToLeft).Column

dlr = dws.Cells(Rows.Count, 2).End(xlUp).Row
If dlr > 1 Then dws.Range("A2:G" & dlr).Clear
y = sws.Range("A4:A" & lr).Value

For i = 2 To lc Step 5
   DoEvents
   dlr = dws.Range("B" & Rows.Count).End(3)(2).Row
   dws.Range("B" & dlr).Offset(0, -1) = sws.Cells(1, i)
   dws.Range("B" & dlr).Resize(UBound(y, 1)).Value = y
   x = sws.Range(sws.Cells(4, i), sws.Cells(lr, i + 4)).Value
   dws.Range("C" & dlr).Resize(UBound(y, 1), 5).Value = x
Next i
dlr = dws.Cells(Rows.Count, 2).End(xlUp).Row
dws.Range("A2:A" & dlr).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
dws.Range("A2:A" & dlr).Value = dws.Range("A2:A" & dlr).Value
dws.Columns.AutoFit
dws.Range("A1").CurrentRegion.Borders.Color = vbBlack
dws.Activate
Application.ScreenUpdating = True
MsgBox "Time taken to process data was " & Format(Now - TimeTaken, "hh:mm:ss")
End Sub

Open in new window

0
 

Author Closing Comment

by:Mohammed Dallag
ID: 41756052
Thank you so much
0
 

Author Comment

by:Mohammed Dallag
ID: 41808230
Dear Subodh Tiwari (Neeraj),

I added three columns to the old format as attached here. Could you please modify the code. I will create a new question for this.

this is the new question


https://www.experts-exchange.com/questions/28971273/How-to-re-arrange-data-in-Excel-sheet.html
Dallag
ReArrangeData_V41.xlsm
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
In Part II of this series, I will discuss how to identify all open instances of Excel and enumerate the workbooks, spreadsheets, and named ranges within each of those instances.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

739 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question