• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 94
  • Last Modified:

how can change the attached excel format

how can change the attached excel format from sheet1 to sheet2 with macro
Book1.xlsx
0
Mohammed Dallag
Asked:
Mohammed Dallag
  • 5
  • 4
1 Solution
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
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
 
Mohammed DallagPetroleum ConsultantAuthor Commented:
I run this and it hang with more data. Please see the attached sheet.
Book3.xlsm
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
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
Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Mohammed DallagPetroleum ConsultantAuthor Commented:
very good but the last well K 51 was written only once. Check the snapshot attached.
2016-07-24_22-47-38.jpg
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
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
 
Mohammed DallagPetroleum ConsultantAuthor Commented:
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
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
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
 
Mohammed DallagPetroleum ConsultantAuthor Commented:
Thank you so much
0
 
Mohammed DallagPetroleum ConsultantAuthor Commented:
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

  • 5
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now