Macro to extract data and paste to a new sheet

[Les]

Could anyone please help
I have what you would call a 'typical' spreadsheet i.e. categories across
row 1, dates down column A then a value against certain categories on certain
dates.
What I'm trying to do is create a macro that extracts the data, the date and
and the category to a new work sheet but only where data actually exists.
I'm essentially trying to create a data table from the existing worksheet.
Regards
Les.

[Norman Jones]

Hi Les,

Try something like:

'================>>
Public Sub CopyTable()
Dim WB As Workbook
Dim SH As Worksheet
Dim destsh As Worksheet
Dim rng As Range
Dim rCell As Range
Dim copyRng As Range
Dim destrng As Range
Dim CalcMode As Long
Dim ViewMode As Long

Set WB = ActiveWorkbook '<<===== CHANGE
Set SH = WB.Sheets("Sheet1") '<<===== CHANGE
Set destsh = WB.Sheets("Sheet2") '<<===== CHANGE
Set destrng = destsh.Range("A1") '<<===== CHANGE

Set rng = SH.Range("A1", Cells(Rows.Count, "A").End(xlUp))

On Error GoTo XIT

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ActiveWindow
ViewMode = .View
.View = xlNormalView
End With

SH.DisplayPageBreaks = False

For Each rCell In rng.Cells
If Application.CountA(rCell.EntireRow) > 1 Then
If copyRng Is Nothing Then
Set copyRng = rCell
Else
Set copyRng = Union(rCell, copyRng)
End If
End If
Next rCell

If Not copyRng Is Nothing Then
copyRng.EntireRow.Copy Destination:=destrng
Else
'nothing found, do nothing
End If

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With

ActiveWindow.View = ViewMode

End Sub
'<<================


---
Regards,
Norman


"Les" <[email protected]> wrote in message
news:[email protected]...
> Could anyone please help
> I have what you would call a 'typical' spreadsheet i.e. categories across
> row 1, dates down column A then a value against certain categories on
> certain
> dates.
> What I'm trying to do is create a macro that extracts the data, the date
> and
> and the category to a new work sheet but only where data actually exists.
> I'm essentially trying to create a data table from the existing worksheet.
> Regards
> Les.
>
>

[Les]

Hi Norman
Thanks for the help and the very quick response.
I know my way around Excel but I'm afraid I'm still getting used to VB.
Could you tell me what is being said in the 'Set' lines of code where you
are saying 'change'.
Thanks
Les.


"Norman Jones" wrote:

> Hi Les,
>
> Try something like:
>
> '================>>
> Public Sub CopyTable()
> Dim WB As Workbook
> Dim SH As Worksheet
> Dim destsh As Worksheet
> Dim rng As Range
> Dim rCell As Range
> Dim copyRng As Range
> Dim destrng As Range
> Dim CalcMode As Long
> Dim ViewMode As Long
>
> Set WB = ActiveWorkbook '<<===== CHANGE
> Set SH = WB.Sheets("Sheet1") '<<===== CHANGE
> Set destsh = WB.Sheets("Sheet2") '<<===== CHANGE
> Set destrng = destsh.Range("A1") '<<===== CHANGE
>
> Set rng = SH.Range("A1", Cells(Rows.Count, "A").End(xlUp))
>
> On Error GoTo XIT
>
> With Application
> CalcMode = .Calculation
> .Calculation = xlCalculationManual
> .ScreenUpdating = False
> End With
>
> With ActiveWindow
> ViewMode = .View
> .View = xlNormalView
> End With
>
> SH.DisplayPageBreaks = False
>
> For Each rCell In rng.Cells
> If Application.CountA(rCell.EntireRow) > 1 Then
> If copyRng Is Nothing Then
> Set copyRng = rCell
> Else
> Set copyRng = Union(rCell, copyRng)
> End If
> End If
> Next rCell
>
> If Not copyRng Is Nothing Then
> copyRng.EntireRow.Copy Destination:=destrng
> Else
> 'nothing found, do nothing
> End If
>
> XIT:
> With Application
> .Calculation = CalcMode
> .ScreenUpdating = True
> End With
>
> ActiveWindow.View = ViewMode
>
> End Sub
> '<<================
>
>
> ---
> Regards,
> Norman
>
>
> "Les" <[email protected]> wrote in message
> news:[email protected]...
> > Could anyone please help
> > I have what you would call a 'typical' spreadsheet i.e. categories across
> > row 1, dates down column A then a value against certain categories on
> > certain
> > dates.
> > What I'm trying to do is create a macro that extracts the data, the date
> > and
> > and the category to a new work sheet but only where data actually exists.
> > I'm essentially trying to create a data table from the existing worksheet.
> > Regards
> > Les.
> >
> >
>
>
>

[Norman Jones]

Hi Les,

> I know my way around Excel but I'm afraid I'm still getting used to VB.
> Could you tell me what is being said in the 'Set' lines of code where you
> are saying 'change'.


> Set WB = ActiveWorkbook '<<===== CHANGE

If the code is to operate on the active workbook, no change is required. If
the code is to operate on the workbook holding the code, change this line
to:

Set WB = ThisWorkbook

If, the code is to operate on another workbook, you will need to provide the
name, e.g.:

Set WB = Workbooks("Les.xls")

where Les.xls is the name of the workbook of interest.

> Set destsh = WB.Sheets("Sheet2") '<<===== CHANGE

Replace Sheet2 with the name of the sheet which is to receive the copied
data.


> Set destrng = destsh.Range("A1") '<<===== CHANGE

ReplaceA1 with the address of the first cell of the destination range for
the copied data.


---
Regards,
Norman


"Les" <[email protected]> wrote in message
news:[email protected]...
> Hi Norman
> Thanks for the help and the very quick response.
> I know my way around Excel but I'm afraid I'm still getting used to VB.
> Could you tell me what is being said in the 'Set' lines of code where you
> are saying 'change'.
> Thanks
> Les.
>