Moving columns of data into rows 1

[bdc138]

I'm working with a large workbook containing 24 sheets. I created a new worksheet with the following columns:

A B C D E F G H I J K L M N
Dir ID Spec 1.5m 0.3 .05m 5m 3m Tall BT

I need to extract data from the current worksheets("Sheet1" through "Sheet 24" and place it in the new worksheet. I want to get the data from "Sheet1" A3 through I3 to be placed in B2 through J2 of the new worksheet. Then I need to copy the data from A4 through I4 into the cells L2 through T2. Then I need to copy the data from cells A5 to I5 into the new worksheet in the cells V2 through AD2. This loop must run until A36 through I36. Therefore all rows of data from the existing worksheet must be placed in a single row of the new worksheet being appended after one another.(and skipping a column before appending each row) Then go to "Sheet2" and do the same thing in row 3 of the new worksheet. Data from "Sheet3" will be placed in row 4 of the new worksheet and so on.... I've been stressing over this for awhile. Any help would be sincerely appreciated.

Thanks,
Brent

 

[Zathras]

If I understand correctly, you would need 340 columns (34 data rows times 9 data columns plus one blank column).

You have a problem: There is a maximum of 255 columns per workshet.

 

[bdc138]

Zathras,
Thank you for taking the time to view my post. I forgot that the data would not fit into one worksheet. If needed, I can use two worksheets to solve the problem. The second worksheet would just append the data that won't fit in the first sheet.

Brent

 

[Zathras]

Ok, assuming you have 24 sheets named "Sheet1" thru "Sheet24" and two more sheets named "NewWorksheet-A" and "NewWorksheet-B" then this macro should do the trick (takes a while to run, so be patient):

Option Explicit
Const NUMBER_OF_SHEETS = 24
Const COL_FROM = 1
Const COL_THRU = 9
Const COL_SPACERS = 1

Sub CopySheets()
Dim i As Integer

  ' Copy rows 3 thru 19 to New Sheet A

  For i = 1 To NUMBER_OF_SHEETS
    CopyRows "Sheet" & i, "NewWorksheet-A", i + 1, 3, 19
  Next i

  ' Copy rows 20 thru 36 to New Sheet B

  For i = 1 To NUMBER_OF_SHEETS
    CopyRows "Sheet" & i, "NewWorksheet-B", i + 1, 20, 36
  Next i
End Sub

Sub CopyRows(FromSheet As String, ToSheet As String, _
          CopyToRow As Long, CopyFromRow As Long, CopyThruRow As Long)
Dim shFrom As Worksheet
Dim shTo As Worksheet
Dim rngCopy As Range
Dim nRow As Long
Dim nColCopyHere
  Application.ScreenUpdating = False
  Set shFrom = Worksheets(FromSheet)
  Set shTo = ActiveWorkbook.Worksheets(ToSheet)
  nColCopyHere = 1
  
  nRow = CopyFromRow
  While nRow <= CopyThruRow
    shFrom.Activate
    Set rngCopy = Range(shFrom.Cells(nRow, COL_FROM), shFrom.Cells(nRow, COL_THRU))
    rngCopy.Copy
    shTo.Activate
    shTo.Paste Destination:=Cells(CopyToRow, nColCopyHere)
    nColCopyHere = nColCopyHere + (COL_THRU - COL_FROM + COL_SPACERS + 1)
    nRow = nRow + 1
  Wend
  
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
  Set shFrom = Nothing
  Set shTo = Nothing
  Set rngCopy = Nothing
End Sub