selecting data from ranges and pasting into new excel sheet 2

[smurf01]

I have an excel work sheet that uses 240 columns, every four columns containg data relating to a specific day and I have 40 rows set up to contain the info, the columns use the following headings

Customer Order Number Quantity Username

As you will quickly work out that means that the columns store data for 60 days ( 240 / 4 = 60). What I want to do is to copy the data from cols A,B,C,D and the rows that contain data into another sheet then I want to copy the data from E,F,G,H and the rows and paste them below the data from A,B,C,D, and so on until I have copied all the data. So in my new sheet I will only have four columns using the headings as shown below to form a table. this table will then be linked to an access query for further data extraction.

Can anyone help me
Regards

Paul

 

[combo]

Assuming your data starts on sheet 1 at A1, with headers in line 1, this code placed in a code module in the same workbook will convert the table:

[tt]Sub ConvertTable()
Dim i As Integer, j As Integer, k As Integer
Dim shNew As Worksheet, shSource As Worksheet
Set shSource = ThisWorkbook.Worksheets(1)
Set shNew = ThisWorkbook.Worksheets.Add
With shNew
.Cells(1, 1).Value = shSource.Cells(1, 1).Value
.Cells(1, 2).Value = shSource.Cells(1, 2).Value
.Cells(1, 3).Value = shSource.Cells(1, 3).Value
.Cells(1, 4).Value = shSource.Cells(1, 4).Value
End With
For i = 1 To 60
addrA1 = Cells(2, 4 * i - 3).Address & ":" & Cells(41, 4 * i).Address
shSource.Range(addrA1).Copy Destination:=shNew.Cells(40 * (i - 1) + 2, 1)
Next i
End Sub[/tt]

 

[rmikesmith]

Paul,

Combo's solution should work fine but I had this just about ready when he posted so decided to share it anyway.

The following procedure will "transpose" your data as requested. The number of data blocks is computed by the code based on the number of columns per repeating unit, which is stored in a constant and can be easily changed. The procedure also dynamically calculates the number of data rows for each repeating unit, in case these also change (even though you said there are 40 rows).

Sub TransposeData()
Const StartRow = 2
Const ColumnsPerBlock = 4
Dim LastDataRow As Long
Dim NextRow As Long
Dim LastDataCol As Integer
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Dim ColumnBlocks As Integer
Dim i As Integer
Dim Col As Integer

  Application.ScreenUpdating = False
  
  Set wksSource = ThisWorkbook.ActiveSheet ' or .Worksheets("SheetName")
  Set wksDest = ThisWorkbook.Worksheets.Add
  wksDest.Name = "Transposed_Data"
  
  With wksSource
    LastDataCol = .Cells(1, 255).End(xlToLeft).Column
    ColumnBlocks = LastDataCol \ ColumnsPerBlock
   
    .Range(.Cells(1, 1), .Cells(1, ColumnsPerBlock)).Copy wksDest.Cells(1, 1)
        
    For i = 1 To ColumnBlocks
      Col = i * ColumnsPerBlock - ColumnsPerBlock + 1
      LastDataRow = .Cells(65536, i).End(xlUp).Row
      NextRow = wksDest.Cells(65536, 1).End(xlUp).Row + 1
      .Range(.Cells(StartRow, Col), .Cells(LastDataRow, Col + 3)).Copy wksDest.Cells(NextRow, 1)
    Next i
  End With
  Application.CutCopyMode = False
  wksDest.Activate
  wksDest.Cells(1, 1).Select
  Application.ScreenUpdating = True
  
End Sub

Regards,
Mike

 

[smurf01]

Mike/Combo
Thanks for your responses, however I am sorry but i failed to explain a couple of Items to you.

1) Row headers are at Row 8
2) Data starts at row 9 and will definitely finish at row 41 thus giving me 33 rows of data.
3) Each Block can contain upto 33 rows of data however, this will depend on orders. Therefore I need to eliminate any rows that do not contain data so that my table does not contain any empty rows.

Combo, your code works great except for the fact that the block is copied in its entirity even if the block contains no data (i.e. if the data in block one of source sheet finishes at row 20 then in destination sheet block 2 will still start at row 34 and so on)

Mike, I seem to having some problems with your code in so much that on some occasions it is copying the headers from row 8 even though i have changed the code line shown below from 2 to 9.

Const StartRow = 2

After that it seems very spasmodic as to whether it picks all the rows with data in them

This is the info stored in block 14 of the source sheet

nicholl 224455 1050 JMcentee
nicholl 224456 1050 JMcentee
NICHOLL 224457 1050 JMcentee
NICHOLL 224458 1200 JMcentee
NICHOLL 224459 1200 JMcentee
NICHOLL 224460 1000 JMcentee
NICHOLL 224461 1050 JMcentee
nicholl 224774 1500 JMcentee

This is what was transposed, just one row

nicholl 224455 1050 JMcentee

Sorry for not giving you all the facts in the first place

Also Another question ? If I have more than 1 worksheet can the coded be changed so that all the data from sheet1 is copied over and then all the data from sheet 2 is copied below that

I appreciate the help you both have given me







Regards

Paul

 

[rmikesmith]

Paul,

Yes, my procedure wasn't quite as robust as I thought! Here is a modified version that keys on the location of the header row (modifications in red):

Sub TransposeData()

Const HeaderRow = 8

Const ColumnsPerBlock = 4
Dim LastDataRow As Long
Dim NextRow As Long
Dim LastDataCol As Integer
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Dim ColumnBlocks As Integer
Dim i As Integer
Dim Col As Integer


  Application.ScreenUpdating = False
  
  Set wksSource = ThisWorkbook.ActiveSheet ' or .Worksheets("SheetName")
  Set wksDest = ThisWorkbook.Worksheets.Add
  wksDest.Name = "Transposed_Data"
  
  With wksSource

    LastDataCol = .Cells(HeaderRow, 255).End(xlToLeft).Column

    ColumnBlocks = LastDataCol \ ColumnsPerBlock

    .Range(.Cells(HeaderRow, 1), .Cells(HeaderRow, ColumnsPerBlock)).Copy wksDest.Cells(1, 1)

    For i = 1 To ColumnBlocks
      Col = i * ColumnsPerBlock - ColumnsPerBlock + 1

      LastDataRow = .Cells(65536, Col).End(xlUp).Row

      NextRow = wksDest.Cells(65536, 1).End(xlUp).Row + 1

.Range(.Cells(HeaderRow + 1, Col), .Cells(LastDataRow, Col + 3)).Copy wksDest.Cells(NextRow, 1)

    Next i
  End With
  Application.CutCopyMode = False
  wksDest.Activate
  wksDest.Cells(1, 1).Select
  Application.ScreenUpdating = True
  
End Sub

Try this and post back as how it works for you.

Regards,
Mike

 

[smurf01]

Mike,
Works great now except that it keeps adding the header row for each block. I only really need the header row once at the top of the table. Also it is good upto block 59 but then on block 60 it pastes rows 6,7,8,9 from that block Regards

Paul

 

[combo]

Hi Paul,
I slightly changed my previuos Sub (and used some of Mike's ideas):

[tt]
Sub ConvertTable2()
Dim i As Integer
Dim bRowTest As Boolean
Dim shSource As Worksheet, shTemp As Worksheet, shNew As Worksheet

Const TitleRowPos As Integer = 8
Const FirstColPos As Integer = 1
Const NoOfDataRows As Integer = 40
Const FieldsInRecord As Integer = 4
Const RecordsInRow As Integer = 60

Set shSource = ThisWorkbook.Worksheets(1)
Set shNew = ThisWorkbook.Worksheets.Add

Application.ScreenUpdating = False

' copying raw blocks
With shSource
' title row
.Range(.Cells(TitleRowPos, FirstColPos), .Cells(TitleRowPos, FirstColPos + FieldsInRecord - 1)).Copy Destination:=shNew.Cells(1, 1)
' data rows
For i = 1 To RecordsInRow
.Range(.Cells(TitleRowPos + 1, FirstColPos + FieldsInRecord * (i - 1)), .Cells(TitleRowPos + NoOfDataRows, FirstColPos + FieldsInRecord * i - 1)).Copy Destination:=shNew.Cells(NoOfDataRows * (i - 1) + 2, 1)
Next i
End With

' delete empty rows
With shNew
For i = NoOfDataRows * RecordsInRow + 1 To 1 Step -1
bRowTest = True
For Each cell_ In .Range(.Cells(i, 1), .Cells(i, FieldsInRecord)).Cells
If Not IsEmpty(cell_) Then
bRowTest = False
Exit For
End If
Next cell_
If bRowTest Then .Rows(i).Delete
Next i
End With

Application.ScreenUpdating = True

End Sub
[/tt]

I added constants to make easier apply changes in data position and size on the sheet (if they don't match your data, change them). I also delete empty rows in the output data, even if they are empty in the middle of the table.

As for your second question - if the position and size of the block data on worksheets is the same - you can use double loop instead (assume you have three first worksheets with data, you can use constant and define it at the beginning of procedure):

[tt]With shSource
' title row
.Range(.Cells(TitleRowPos, FirstColPos), .Cells(TitleRowPos, FirstColPos + FieldsInRecord - 1)).Copy Destination:=shNew.Cells(1, 1)
end With
' data rows
For j=1 to 3 ' suppose you have 3 data sheets
set shSource=worksheets(j)
With shSource
For i = 1 To RecordsInRow
.Range(.Cells(TitleRowPos + 1, FirstColPos + FieldsInRecord * (i - 1)), .Cells(TitleRowPos + NoOfDataRows, FirstColPos + FieldsInRecord * i - 1)).Copy Destination:=shNew.Cells(NoOfDataRows * (i - 1) +(j-1) * NoOfDataRows * RecordsInRow + 2, 1)
Next i
Next j
End With[/tt]

and extend cleaning loop:

[tt]For i = 3 * NoOfDataRows * RecordsInRow + 1 To 1 Step -1[/tt]

 

[smurf01]

Mike,
Sorry I am giving you "duff info" again what it is actually doing is, if a block has no data in it at all it is then pasting the header row for that block. Perhaps what i should do is explain what the sheet does. Basically when we recieve orders for various machines the data is entered into the spreadsheet in the block relating to the date the order is required. therefore if for instance we have no orders for 14/01/03 then rows 9 to 40 in that block will be empty.

Hope this helps Regards

Paul

 

[smurf01]

Combo,
"GREAT" That code works perfectly. As to the the code you posted for my 2nd question where would i place that code in the "SUB". Sorry to be a pain but I have not done much complex code like this and i struggle sometimes to understand.

By the way You and Mike are Great I have posted you both Stars for this info Regards

Paul

 

[combo]

Paul,

You should replace a part of code under the comment
[tt]'copying raw blocks[/tt] until first blank row - the code copies header and blocks using loop "For i=1..."

Extending to many pages option, I copy header and next, in double loop, blocks within page (i index) and for pages (j index), assigning worksheets to variable shSource.

The second change is in the cleaning section - simply increase loop size due to more than one page of data, and exchange one line.

Hope this will work as I was doing changes on this forum.

BTW, shTemp is not used, you can delete the declaration (I was thinking of other solution).

Thx 4 star!

Combo

 

[smurf01]

Combo,
Thank You for that, I changed this bit of your code
Set shSource = ThisWorkbook.Worksheets(1)so that it read
Set shSource = ThisWorkbook.Worksheets("924s&quotAs this is what my sheet was called that i tested on. My other sheets are ("718s&quot and ("519&quot.

My question is how would i define these so that the code will extract all the data from these three sheets

Regards

Paul

 

[combo]

I suggest to use array of worksheet objects, assign worksheets to the items of array and refer to them by index:

in declarations section:
[tt]Dim shArray(3) As Worksheet[/tt]

under constants definition:
[tt]Set shArray(1) = ThisWorkbook.Worksheets("924s&quot
Set shArray(2) = ThisWorkbook.Worksheets("718s&quot
Set shArray(3) = ThisWorkbook.Worksheets("519&quot[/tt]

Now you can assign data worksheets using shArray in your code:
shArray(1) instead ThisWorkbook.Worksheets(1)
shArray(j) instead ThisWorkbook.Worksheets(j)

This should also add better control of the code (does not depend on the order of worksheets in the workbook).

Best regards

Combo

 

[smurf01]

Combo,
Sorry to be a pain but I am getting an error message when trying to run the code, it says Compile Error ( next without For). I have pasted the code and put a comment next to the point that the error points to


Sub ConvertTable3()
Dim i As Integer
Dim bRowTest As Boolean
Dim shSource As Worksheet, shTemp As Worksheet, shNew As Worksheet
Dim shArray(3) As Worksheet


Const TitleRowPos As Integer = 8
Const FirstColPos As Integer = 1
Const NoOfDataRows As Integer = 40
Const FieldsInRecord As Integer = 4
Const RecordsInRow As Integer = 60
Set shArray(1) = ThisWorkbook.Worksheets("924s&quot
Set shArray(2) = ThisWorkbook.Worksheets("718s&quot
Set shArray(3) = ThisWorkbook.Worksheets("519&quot


Set shSource = shArray(1)
Set shNew = ThisWorkbook.Worksheets.Add
shNew.Name = "Converted_Table3"

Application.ScreenUpdating = False

' copying raw blocks
With shSource
' title row
.Range(.Cells(TitleRowPos, FirstColPos), .Cells(TitleRowPos, FirstColPos + FieldsInRecord - 1)).Copy Destination:=shNew.Cells(1, 1)
End With
' data rows
For j = 1 To 3 ' suppose you have 3 data sheets
Set shSource = shArray(j)
With shSource
For i = 1 To RecordsInRow
.Range(.Cells(TitleRowPos + 1, FirstColPos + FieldsInRecord * (i - 1)), .Cells(TitleRowPos + NoOfDataRows, FirstColPos + FieldsInRecord * i - 1)).Copy Destination:=shNew.Cells(NoOfDataRows * (i - 1) + (j - 1) * NoOfDataRows * RecordsInRow + 2, 1)
Next i
Next j '( This is where the error points to)
End With
Regards

Paul

 

[rmikesmith]

Paul,

Here is the latest version of my procedure if you wish to try it out. I have corrected the problem for cases where there is no data for a given block. That's the downside of running this stuff on made-up data! This also supports appending data from multiple sheets. The code checks for an existing destination sheet then gives the user options. The way this is currently written, data will be moved from the active worksheet, meaning that you will need to select each sheet in turn and run the procedure. Modified procedure (I recommend replacing existing procedure wholesale):

Sub TransposeData()
Const HeaderRow = 8
Const ColumnsPerBlock = 4
Const Destination_Sheet_Name = "Transposed_Data"
Dim LastDataRow As Long
Dim NextRow As Long
Dim LastDataCol As Integer
Dim wks As Worksheet
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Dim ColumnBlocks As Integer
Dim i As Integer
Dim Col As Integer
Dim Response As Integer
Dim Destination_Sheet_Exists As Boolean
Dim msg As String


  Application.ScreenUpdating = False
  
  Set wksSource = ThisWorkbook.ActiveSheet
  
  For Each wks In ThisWorkbook.Worksheets
    If wks.Name = Destination_Sheet_Name Then
      Destination_Sheet_Exists = True
      Set wksDest = wks
      Exit For
    End If
  Next wks
  
  If Destination_Sheet_Exists Then
    msg = "The destination worksheet already exists.  Do you want to append the new data to it?"
    msg = msg & vbCrLf & "(Choosing No will delete the existing destination sheet)"
    Response = MsgBox(msg, vbQuestion + vbYesNoCancel, "Transpose Data")
    If Response = vbCancel Then
      Exit Sub
    ElseIf Response = vbNo Then
      Application.DisplayAlerts = False
      wksDest.Delete
      Application.DisplayAlerts = True
      Set wksDest = ThisWorkbook.Worksheets.Add
      wksDest.Name = "Transposed_Data"
    End If
  Else
    Set wksDest = ThisWorkbook.Worksheets.Add
    wksDest.Name = "Transposed_Data"
  End If
  
  With wksSource
    LastDataCol = .Cells(HeaderRow, 255).End(xlToLeft).Column
    ColumnBlocks = LastDataCol \ ColumnsPerBlock
   
    .Range(.Cells(HeaderRow, 1), .Cells(HeaderRow, ColumnsPerBlock)).Copy wksDest.Cells(1, 1)
        
    For i = 1 To ColumnBlocks
      Col = i * ColumnsPerBlock - ColumnsPerBlock + 1
      LastDataRow = .Cells(65536, Col).End(xlUp).Row
      If LastDataRow > HeaderRow Then
        NextRow = wksDest.Cells(65536, 1).End(xlUp).Row + 1
        .Range(.Cells(HeaderRow + 1, Col), .Cells(LastDataRow, Col + 3)).Copy wksDest.Cells(NextRow, 1)
      End If
    Next i
  End With
  Application.CutCopyMode = False
  wksDest.Activate
  wksDest.Cells(1, 1).Select
  Application.ScreenUpdating = True
  
End Sub

HTH
Mike

 

[smurf01]

Mike,
"Brilliant" Thanks so Much, runs like a dream

You and Combo are "Stars", I would never have worked that out Regards

Paul

 

[combo]

Paul,
here is the code for 3 data pages.
[tt]
Sub ConvertTable2()
Dim i As Integer
Dim bRowTest As Boolean
Dim shSource As Worksheet, shNew As Worksheet
Dim shArray(3) As Worksheet ' 3 data sheets

Const TitleRowPos As Integer = 8
Const FirstColPos As Integer = 1
Const NoOfDataRows As Integer = 40
Const FieldsInRecord As Integer = 4
Const RecordsInRow As Integer = 60

Set shNew = ThisWorkbook.Worksheets.Add

' here uou assign sheets to array
Set shArray(1) = ThisWorkbook.Worksheets("924s&quot
Set shArray(2) = ThisWorkbook.Worksheets("718s&quot
Set shArray(3) = ThisWorkbook.Worksheets("519&quot

Application.ScreenUpdating = False

' copying raw blocks
Set shSource = shArray(1)
With shSource
' title row
.Range(.Cells(TitleRowPos, FirstColPos), .Cells(TitleRowPos, FirstColPos + FieldsInRecord - 1)).Copy Destination:=shNew.Cells(1, 1)
End With
' data rows
For j = 1 To 3 ' you have 3 data sheets
Set shSource = shArray(j)
With shSource
For i = 1 To RecordsInRow
.Range(.Cells(TitleRowPos + 1, FirstColPos + FieldsInRecord * (i - 1)), .Cells(TitleRowPos + NoOfDataRows, FirstColPos + FieldsInRecord * i - 1)).Copy Destination:=shNew.Cells(NoOfDataRows * (i - 1) + (j - 1) * NoOfDataRows * RecordsInRow + 2, 1)
Next i
End With
Next j

' delete empty rows
With shNew
For i = 3 * NoOfDataRows * RecordsInRow + 1 To 1 Step -1 ' 3 source sheets again
bRowTest = True
For Each cell_ In .Range(.Cells(i, 1), .Cells(i, FieldsInRecord)).Cells
If Not IsEmpty(cell_) Then
bRowTest = False
Exit For
End If
Next cell_
If bRowTest Then .Rows(i).Delete
Next i
End With
End Sub
[/tt]

Hope this will be useful
Combo

 

[rmikesmith]

Hey Combo,

You and I may have too much time on our hands!


Regards,
Mike

 

[smurf01]

Am I glad about that :-D Regards

Paul

 

[smurf01]

Mike/Combo,
As i said in my original post I intend to use the data i extract from my sheets in an access query, I then intend through the use of MSQuery to return the validated data to another worksheet named InputData. The data will contain the following columns

1) machine Number (i.e. 924s, 718s,519)
2) Date ( i.e. From Today + 60 Days)
3) Customer (i.e. Paul, Mike, Combo)
4) Order Number ( i.e. 123456/1, 654321/1, 987654/1)
4) Quantity (i.e. 1000,2000,3000)
5) username (i.e. Paul, Mike, Combo)

My question is this ??
Can i append the data to the Blocks in the original sheet that I extracted the data from so for instance, If Machine = 924s and Date = 13/01/03 then in Worksheet 924s in the first block, from the first row ( which would be Row 9)it would show

Customer Order Number Quantity Username
Paul 123456/1 1000 Paul


Hope this makes sense




Regards

Paul

 

[combo]

Hi Paul,
As i understand, your problem is a little wider than described at the top of this thread.
Basically, I think two steps are worth considering to answer your question:
1. add page name (i.e. machine number) as fifth column of output data, and order date as sixth column,
2. transfer date to access database, using querry appending fields.
However, at least in my idea, some extra work is necessary (extract date, add page name). Basing on our proposal, try to extend the code.

An alternative is to build more sofisticated excel application managing orders and probably rearranging data in a different way.
If you do not expect full automation and accept some manual work, six column output table + pivot table as a reporting tool can be the basic solution for extracting data. Pivot table can be really a powerful tool if the data is organized wisely.

Hope this is a good starting point to develop your application.



Hi Mike,
I use the same message to address to you. I also learned something from your code, and the information costs - here the time is a price.
Hope you had a good Sunday

Combo