PDA

View Full Version : Combining multiple worksheets WITHOUT the same arrangement.



turtsmurt
04-07-2010, 09:57 AM
Can anyone please suggest the best way for me to combine 100 worksheets into a master sheet if the information is NOT in the same format in every sheet? I was given all of this information as text and converted it to Excel in order to analyze.

I am trying to combined all 100 sheets into 1 master sheet so that I can use a Pivot table with these column headings, Year, Month, District, Location Number, Count of Notices...

Here is an example of my worksheets...

This is the information in one of the worksheets...

DISTRICT0100Location1/20102/20103/20104/20105/20106/20107/20108/20109/201010/201011/201012/201001415335503301319385214143881421110621353010111114513114372315754164312 18111920131711

Here is another worksheet....

DISTRICT0700Location1/20102/20103/20104/20105/20106/20108/20109/201001136610317117219611569316306411214111132411433311521216641712181119917 221

Here is another one...


DISTRICT
1700Location1/20102/20103/20104/20105/20106/20107/20108/20109/201010/201011/201012/201001956079603446499561360241134184611064236502309111442131848147122815141 815216105211832119412734101
Thanks in advance,
Christine:dunno

lucas
04-07-2010, 10:04 AM
Try this. It will combine all sheets in a workbook to a new worksheet:

Sub Combine_Sheets()
Dim wshTemp As Worksheet, wsh As Worksheet
Dim rngArr() As Range, c As Range
Dim i As Integer
Dim j As Integer
ReDim rngArr(1 To 1)
For Each wsh In ActiveWorkbook.Worksheets
i = i + 1
If i > 1 Then ' resize array
ReDim Preserve rngArr(1 To i)
End If
On Error Resume Next
Set c = wsh.Cells.SpecialCells(xlCellTypeLastCell)
If Err = 0 Then
On Error GoTo 0
'Prevent empty rows
Do While Application.CountA(c.EntireRow) = 0 _
And c.EntireRow.Row > 1
Set c = c.Offset(-1, 0)
Loop
Set rngArr(i) = wsh.Range(wsh.Range("A1"), c)
End If
Next wsh
'Add temp.Worksheet
Set wshTemp = Sheets.Add(after:=Worksheets(Worksheets.Count))
On Error Resume Next
With wshTemp
For i = 1 To UBound(rngArr)
If i = 1 Then
Set c = .Range("A1")
Else
Set c = _
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
Set c = c.Offset(2, 0).End(xlToLeft) ' skip one row
End If
'Copy-paste range (prevent empty range)
If Application.CountA(rngArr(i)) > 0 Then
rngArr(i).Copy c
End If
Next i
End With
On Error GoTo 0
Application.CutCopyMode = False ' prevent marquies
With ActiveSheet.PageSetup ' Fit to 1 page
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With

End Sub