Sub RunMe() Dim sh As Worksheet, mHeader As Boolean, mR, sR As Long, mC, sC As Integer Application.ScreenUpdating = False Sheets.Add before:=Sheets(1) ActiveSheet.Name = "Main" mR = 2 With Sheets("Main") For Each sh In Worksheets sh.Select If sh.Name <> "Main" Then If mHeader = False Then .Range("A1").Value = Range("A2").Value .Range("B1").Value = Range("C2").Value .Range("C1").Value = Range("E2").Value .Range("D1").Value = Range("A4").Value .Range("E1").Value = Range("C4").Value .Range("F1").Value = Range("E4").Value .Range("G1").Value = Range("A6").Value .Range("H1").Value = Range("C6").Value .Range("I1").Value = Range("E6").Value .Range("J1").Value = Range("A9").Value .Range("K1").Value = Range("C9").Value .Range("L1").Value = Range("E9").Value .Range("M1").Value = Range("G9").Value mHeader = True End If .Range("A" & mR).Value = Range("A3").Value .Range("B" & mR).Value = Range("C3").Value .Range("C" & mR).Value = Range("E3").Value .Range("D" & mR).Value = Range("A5").Value .Range("E" & mR).Value = Range("C5").Value .Range("F" & mR).Value = Range("E5").Value .Range("G" & mR).Value = Range("A7").Value .Range("H" & mR).Value = Range("C7").Value .Range("I" & mR).Value = Range("E7").Value .Select Range(Cells(mR, "A"), Cells(mR, "I")).Copy .Range(Cells(mR + 1, "A"), Cells(mR + 6, "I")) sR = 10 sC = 1 mC = 10 Do Cells(mR, mC).Value = sh.Cells(sR, sC).Value sC = sC + 2 mC = mC + 1 If sC = 9 Then sR = sR + 1 sC = 1 mR = mR + 1 mC = 10 End If Loop Until sR = 17 End If Next sh End With Rows(1).Font.Bold = True Cells.EntireColumn.AutoFit Range("A2").Select ActiveWindow.FreezePanes = True Application.ScreenUpdating = True End Sub
Sub RunMeV2() Dim sh As Worksheet, mHeader As Boolean, mR As Long, mC, sR, sC, x As Integer Application.ScreenUpdating = False Sheets.Add before:=Sheets(1) ActiveSheet.Name = "Main" mR = 1 'Main Row mC = 1 'Main Column sR = 2 'Sheet Row sC = 1 'Sheet Column x = 1 'Counter to add to the header of Sheets row 9 With Sheets("Main") 'Whenever a line starts a . we are referring to main sheet For Each sh In Worksheets sh.Select If sh.Name <> "Main" Then If mHeader = False Then Do .Cells(mR, mC).Value = Cells(sR, sC).Value 'Cells(row,column) mC = mC + 1 sC = sC + 2 If sC = 7 Then sC = 1 sR = sR + 2 End If Loop Until mC = 10 sR = 9 Do .Cells(mR, mC).Value = Cells(sR, sC).Value & x mC = mC + 1 sC = sC + 2 If sC = 9 Then sC = 1 x = x + 1 End If Loop Until x = 8 mHeader = True End If mR = mR + 1 mC = 1 sR = 3 sC = 1 Do .Cells(mR, mC).Value = Cells(sR, sC).Value mC = mC + 1 sC = sC + 2 If sC = 7 Then sR = sR + 2 sC = 1 End If Loop Until mC = 10 sR = 10 sC = 1 mC = 10 Do .Cells(mR, mC).Value = sh.Cells(sR, sC).Value sC = sC + 2 mC = mC + 1 If sC = 9 Then sR = sR + 1 sC = 1 End If Loop Until sR = 17 mC = 10 End If Next sh .Select End With Rows(1).Font.Bold = True Cells.EntireColumn.AutoFit Range("A2").Select ActiveWindow.FreezePanes = True Application.ScreenUpdating = True End Sub
I will try this and I will let you know.
Thank you
It's a nice code and it working very fine.
I am not that much good with codes, but I try to read and understand what is written
I appreciate your effort and time that I took for me. Did you know that with this code you saved me a lot of time that I will waste in collecting this information page by page I have to collect 7,425 sheets really it will take weeks or maybe months.
Many thanks dear.
hope you fine
dear, I did some change in my table,
from 1-9 are perfect.
from 10-13 I make change on it.
the final picture is (all cells one Row from A1- AK2)
I understood the code steps from A1-A9 only :). however, the rest its bit hard.
I hope you get my idea in final clear picture.
it is possible to teach me how can I change the code whenever I want?
OR
you can do easy code for me to learn step by step.
Thank you so much for your patience.
BR