Macro to extract data and paste to a new sheet

[Guest]

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
'<<================

 

[Guest]

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]

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.