Solved

how can change the attached excel format

Posted on 2016-07-17
9
63 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 28

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 28

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
 

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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 28

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 28

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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

Drop Down List with Unique/Distinct Values (Part II - ComboBox or ListBox and Data Validation List Bonus!) David Miller (dlmille) Intro This article focuses on delivering unique, sorted lists to list objects (e.g., ComboBox, ListBox) and Dat…
This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

920 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

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now