Solved

how can change the attached excel format

Posted on 2016-07-17
9
70 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:dallagmm
  • 5
  • 4
9 Comments
 
LVL 29

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:dallagmm
ID: 41726576
I run this and it hang with more data. Please see the attached sheet.
Book3.xlsm
0
 
LVL 29

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
Are your AD admin tools letting you down?

Managing Active Directory can get complicated.  Often, the native tools for managing AD are just not up to the task.  The largest Active Directory installations in the world have relied on one tool to manage their day-to-day administration tasks: Hyena. Start your trial today.

 

Author Comment

by:dallagmm
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 29

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:dallagmm
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 29

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:dallagmm
ID: 41756052
Thank you so much
0
 

Author Comment

by:dallagmm
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

NAS Cloud Backup Strategies

This article explains backup scenarios when using network storage. We review the so-called “3-2-1 strategy” and summarize the methods you can use to send NAS data to the cloud

Question has a verified solution.

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

Introduction This Article is a follow-up to my Mappit! Addin Article (http://www.experts-exchange.com/A_2613.html), it was inspired by an email posting I made to EUSPRIG (http://www.eusprig.org/index.htm), I will briefly cover: 1) An overvie…
Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

778 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