Solved

how can change the attached excel format

Posted on 2016-07-17
9
60 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
How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

 
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

Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

Join & Write a Comment

Drop Down List with Unique/Distinct Values (enhancing the Combo-Box with a few steps and a little code) David miller (dlmille) Intro Have you ever created a data validation list from a database field or spreadsheet column (e.g., Zip Codes or Co…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Viewers will learn the basics of slicers and timelines for both PivotTables and standard Excel tables in Excel 2013.
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…

744 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

16 Experts available now in Live!

Get 1:1 Help Now