Link to home
Start Free TrialLog in
Avatar of Jorgen
JorgenFlag for Denmark

asked on

VBA to copy data from area and insert this data to an Excel Table

Hi Experts

I have a spreadsheet, where I copy some of the data from a pivottable to another sheet, and paste the information below existing data.

This is done by VBA, and repeats itself based on a timer.

It Works and can be used, but I would prefer to paste the data to a Table called Tbl_Summarized, as i have a lot of other calculations that can use the advantages of the functionality in tables.

How can I change the code below, so it will always append my copied area to the existing table (insert rows below existing rows of data in my table)?

Option Explicit

'Dim as a Public variable and it will be available to all Procedures in all modules.
Public rTime As Date
Dim rwInMax As Long
Dim rwIn As Long


Sub CellValueAutoIncr1()
'This procedure uses the OnTime Method to auto increment cell value at specific time intervals, and Stops the procedure on crossing a specific cell value.

'To run a procedure at a specific time, use TimeValue(time) viz. TimeValue("20:30:00") will run a procedure at 8.30 pm. To run a procedure at specified time intervals (say, from now), use Now + TimeValue(time) viz. Now + TimeValue("00:00:15") sets the time interval at 15 seconds, at which interval the procedure will run.

'set the time interval at 15 seconds, at which interval the procedure will run.

rTime = Now + TimeValue("00:00:15")
 
Application.ScreenUpdating = False
 
'procedure named CellValueAutoIncr1 will autmatically run, at the sheduled time interval, with the OnTime Method.
Application.OnTime EarliestTime:=rTime, Procedure:="CellValueAutoIncr1", schedule:=True

'increment the value in cell A1 (in Active Worksheet) by 1, for each time the Macro is repeated:
Cells(1, 1).Value = Cells(1, 1).Value + 1

Worksheets("Dataload").Select
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
Worksheets("Pivot").Select
Worksheets("Pivot").PivotTables("Pivottabel1").PivotCache.Refresh

rwInMax = Worksheets("Dagens summerede Data").Range("A1").CurrentRegion.Rows.Count
rwInMax = rwInMax

Worksheets("Pivot").Range("A6").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    
Worksheets("Dagens summerede Data").Select
Worksheets("Dagens summerede Data").Range("A" & rwInMax).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

rwInMax = Worksheets("Dagens summerede Data").Range("A1").CurrentRegion.Rows.Count
    
For rwIn = 3 To rwInMax - 1 'rwInMax      'repeat until you reach the bottom of the sourcesheet or actually the datarange set

        If IsEmpty(Worksheets("Dagens summerede Data").Range("H" & (rwIn))) Then

            If Not IsEmpty(Worksheets("Dagens summerede Data").Range("A" & (rwIn))) Then

                Worksheets("Dagens summerede Data").Range("H" & (rwIn)) = Format(Now, "hh:mm:ss")

            Else

            End If

        Else

        End If

    Next rwIn

Worksheets("Test").Select

Application.ScreenUpdating = True


If Cells(1, 1).Value > 1 Then

Application.OnTime rTime, "CellValueAutoIncr1", , False

End If

End Sub

Open in new window

Avatar of Rgonzo1971
Rgonzo1971

Hi,

If you paste your data at the end of table, the table will normally expand to include these new rows

Regards
Try this. Note that I have assumed that the table in question is also on the "Dagens summerede Data". You will need to amend this if it is not the case.

Option Explicit

'Dim as a Public variable and it will be available to all Procedures in all modules.
Public rTime As Date

Sub CellValueAutoIncr1()
'This procedure uses the OnTime Method to auto increment cell value at specific time intervals, and Stops the procedure on crossing a specific cell value.

'To run a procedure at a specific time, use TimeValue(time) viz. TimeValue("20:30:00") will run a procedure at 8.30 pm. To run a procedure at specified time intervals (say, from now), use Now + TimeValue(time) viz. Now + TimeValue("00:00:15") sets the time interval at 15 seconds, at which interval the procedure will run.

'set the time interval at 15 seconds, at which interval the procedure will run.

rTime = Now + TimeValue("00:00:15")
 
Application.ScreenUpdating = False
 
'procedure named CellValueAutoIncr1 will autmatically run, at the sheduled time interval, with the OnTime Method.
Application.OnTime EarliestTime:=rTime, Procedure:="CellValueAutoIncr1", schedule:=True

'increment the value in cell A1 (in Active Worksheet) by 1, for each time the Macro is repeated:
Worksheets("Test").Select
Cells(1, 1).Value = Cells(1, 1).Value + 1

Worksheets("Dataload").Select
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
Worksheets("Pivot").Select
Worksheets("Pivot").PivotTables("Pivottabel1").PivotCache.Refresh

Worksheets("Pivot").Range("A6").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

' ##### Select the sheet containing the table Tbl_Summarized #####
 Sheets("Dagens summerede Data").Select
    Range("Tbl_Summarized[#Headers]").Select
    Selection.End(xlToRight).Select
    Dim newRow As ListRow
    Set newRow = Selection.ListObject.ListRows.Add(AlwaysInsert:=False)
    newRow.Range.Select
    ActiveSheet.Paste
    
Worksheets("Test").Select

Application.ScreenUpdating = True

If Cells(1, 1).Value > 1 Then

Application.OnTime rTime, "CellValueAutoIncr1", , False

End If

End Sub

Open in new window

Is this where the Table is?

Worksheets("Dagens summerede Data"?

What is the Loop for? Is it formatting as Time?

This code is untested so try it on a backup workbook

'Dim as a Public variable and it will be available to all Procedures in all modules.
Public rTime As Date
Dim rwInMax As Long
Dim rwIn As Long


Sub CellValueAutoIncr1()
'This procedure uses the OnTime Method to auto increment cell value at specific time intervals, and Stops the procedure on crossing a specific cell value.

'To run a procedure at a specific time, use TimeValue(time) viz. TimeValue("20:30:00") will run a procedure at 8.30 pm. To run a procedure at specified time intervals (say, from now), use Now + TimeValue(time) viz. Now + TimeValue("00:00:15") sets the time interval at 15 seconds, at which interval the procedure will run.

'set the time interval at 15 seconds, at which interval the procedure will run.
    Dim oTbl As ListObject
    Dim oRw As ListRow

    rTime = Now + TimeValue("00:00:15")

    Application.ScreenUpdating = False

    'procedure named CellValueAutoIncr1 will autmatically run, at the sheduled time interval, with the OnTime Method.
    Application.OnTime EarliestTime:=rTime, Procedure:="CellValueAutoIncr1", schedule:=True

    'increment the value in cell A1 (in Active Worksheet) by 1, for each time the Macro is repeated:
    Cells(1, 1).Value = Cells(1, 1).Value + 1

    Worksheets("Dataload").Select
    Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
    Worksheets("Pivot").Select
    Worksheets("Pivot").PivotTables("Pivottabel1").PivotCache.Refresh

    rwInMax = Worksheets("Dagens summerede Data").Range("A1").CurrentRegion.Rows.Count
    rwInMax = rwInMax

    With Worksheets("Dagens summerede Data")
        Set oTbl = .ListObjects("Tbl_Summarized")
        Worksheets("Pivot").Range("A6").CurrentRegion.Copy

        Set oRw = oTbl.ListRows.Add(AlwaysInsert:=True)
        Range.Cells(1, 1).PasteSpecial xlValues

        rwInMax = oTbl.ListRows.Count
        'not sure what you are doing here
        For rwIn = 3 To rwInMax - 1    'rwInMa otbl.x      'repeat until you reach the bottom of the sourcesheet or actually the datarange set

            If IsEmpty(.Range("H" & (rwIn))) Then

                If Not IsEmpty(.Range("A" & (rwIn))) Then

                    .Range("H" & (rwIn)) = Format(Now, "hh:mm:ss")

                Else

                End If

            Else

            End If

        Next rwIn
    End With
    Worksheets("Test").Select

    Application.ScreenUpdating = True


    If Cells(1, 1).Value > 1 Then

        Application.OnTime rTime, "CellValueAutoIncr1", , False

    End If

End Sub

Open in new window

Hi,

pls try

 Range("Tbl_Summarized").End(xlDown).Offset(1).Select
 ActiveSheet.Paste

Regards
Avatar of Jorgen

ASKER

Hi Guys

I have tried to insert data below, but for some reason, it seems like just pasting without expanding the table.

Yes the Worksheets("Dagens summerede Data"? is where data goes.

 The loop secures, that we have a timestamp on all new records. We need a summarised view every 10 minutes to decide speed. ( I know, that in the code it says 15 seconds at the moment)

I prefer the table solution, if it Works, but I sure will test both versions

regards

Jørgen
Could you send a dummy?
Have you tried the amended code it should add the data to the bottom of the data table.  A dummy workbook would help for testing the code.
Avatar of Jorgen

ASKER

@ Roy,

I get the following compile error on the bold code - any suggestions

Set oRw = oTbl.ListRows.Add(AlwaysInsert:=True)
       Range.Cells(1, 1).PasteSpecial xlValues



Compile Error:
Argument not optional

@ Rgonzo

I will test your suggestion first - and if it does not Work, I will see if I can send a dummy, but it is a Little complex to extract the correct data

regards

Jørgen
Avatar of Jorgen

ASKER

@Rgonzo

I get the following error:
Application defined or object defined error

any suggestions
Sorry, try this

orw.Range.Cells(1, 1).PasteSpecial xlValues

Open in new window

Okay, I have put the timestamp code back in. Please confirm whether or not this works for you.

Option Explicit

'Dim as a Public variable and it will be available to all Procedures in all modules.
Public rTime As Date

Sub CellValueAutoIncr1()
'This procedure uses the OnTime Method to auto increment cell value at specific time intervals, and Stops the procedure on crossing a specific cell value.

'To run a procedure at a specific time, use TimeValue(time) viz. TimeValue("20:30:00") will run a procedure at 8.30 pm. To run a procedure at specified time intervals (say, from now), use Now + TimeValue(time) viz. Now + TimeValue("00:00:15") sets the time interval at 15 seconds, at which interval the procedure will run.

'set the time interval at 15 seconds, at which interval the procedure will run.

rTime = Now + TimeValue("00:00:15")
 
Application.ScreenUpdating = False
 
'procedure named CellValueAutoIncr1 will autmatically run, at the sheduled time interval, with the OnTime Method.
Application.OnTime EarliestTime:=rTime, Procedure:="CellValueAutoIncr1", schedule:=True

'increment the value in cell A1 (in Active Worksheet) by 1, for each time the Macro is repeated:
Worksheets("Test").Select
Cells(1, 1).Value = Cells(1, 1).Value + 1

Worksheets("Dataload").Select
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
Worksheets("Pivot").Select
Worksheets("Pivot").PivotTables("Pivottabel1").PivotCache.Refresh

Worksheets("Pivot").Range("A6").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

' ##### Select the sheet containing the table Tbl_Summarized #####
 Sheets("Dagens summerede Data").Select
    Range("Tbl_Summarized[#Headers]").Select
    Dim newRow As ListRow
    ' The next line works with AlwaysInsert:=False. Changing this to True breaks cancels the copy therefore breaking the paste
    Set newRow = Selection.ListObject.ListRows.Add(AlwaysInsert:=False)
    newRow.Range(1, 1).Select
    ActiveSheet.Paste
    ' Assuming timestamp goes in the eighth column of the table
    newRow.Range.Cells(1, 8).Select
    ' ***** The next line will cause trouble if only a single row was pasted
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormulaR1C1 = Format(Now, "hh:mm:ss")
    
Worksheets("Test").Select

Application.ScreenUpdating = True

If Cells(1, 1).Value > 1 Then

Application.OnTime rTime, "CellValueAutoIncr1", , False

End If

End Sub

Open in new window

Why use Selection?

To add the Time Stamp using my oTbl variable

 oTbl.ListColumns(8).SpecialCells(xlCellTypeBlanks).Value = Format(Time, "hh:mm:ss")

Open in new window

Avatar of Jorgen

ASKER

@ scsyme

The code stops at ActiveSheet.Paste

@ Roy

No difference if I changed the code.

regards

Jørgen
Avatar of Jorgen

ASKER

Hi Roy,

The Timestamp is my smallest problem. If the general paste Works, I am fully satisfied.

regards

Jørgen
Jorgen

An example workbook would really help.

I use similar code to this regularly. Try this and note any error messages

Sub CellValueAutoIncr1()
'This procedure uses the OnTime Method to auto increment cell value at specific time intervals, and Stops the procedure on crossing a specific cell value.

'To run a procedure at a specific time, use TimeValue(time) viz. TimeValue("20:30:00") will run a procedure at 8.30 pm. To run a procedure at specified time intervals (say, from now), use Now + TimeValue(time) viz. Now + TimeValue("00:00:15") sets the time interval at 15 seconds, at which interval the procedure will run.

'set the time interval at 15 seconds, at which interval the procedure will run.
    Dim oTbl As ListObject
    Dim oRw As ListRow

    rTime = Now + TimeValue("00:00:15")

    Application.ScreenUpdating = False

    'procedure named CellValueAutoIncr1 will autmatically run, at the sheduled time interval, with the OnTime Method.
    Application.OnTime EarliestTime:=rTime, Procedure:="CellValueAutoIncr1", schedule:=True

    'increment the value in cell A1 (in Active Worksheet) by 1, for each time the Macro is repeated:
    Cells(1, 1).Value = Cells(1, 1).Value + 1

    Worksheets("Dataload").Select
    Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
    Worksheets("Pivot").Select
    Worksheets("Pivot").PivotTables("Pivottabel1").PivotCache.Refresh

    rwInMax = Worksheets("Dagens summerede Data").Range("A1").CurrentRegion.Rows.Count
    rwInMax = rwInMax

    With Worksheets("Dagens summerede Data")
        Set oTbl = .ListObjects("Tbl_Summarized")
        Worksheets("Pivot").Range("A6").CurrentRegion.Copy

        Set oRw = oTbl.ListRows.Add(AlwaysInsert:=True)
        oRw.Range.Cells(1, 1).Resize(, 7).PasteSpecial xlValues
        oTbl.ListColumns(8).SpecialCells(xlCellTypeBlanks).Value = Format(Time, "hh:mm:ss")
    End With
    Worksheets("Test").Select

    Application.ScreenUpdating = True

    If Cells(1, 1).Value > 1 Then
        Application.OnTime rTime, "CellValueAutoIncr1", , False
    End If

End Sub

Open in new window

Avatar of Jorgen

ASKER

Hi Roy,

I will send an example file.

I just need to disconnect from server.

regards

Jørgen
Thanks
Avatar of Jorgen

ASKER

Hi all,

I have put your code in the (3) macro, while my original code is in the (1) macro

If you have questions, please get back to me

regards

Jørgen
EE-Produktion-Dashboard.xlsm
The copy seems to work fine now. Will you always be copying to a blank table? If not the code will need a slight adjustment

Sub CellValueAutoIncr1a()
'This procedure uses the OnTime Method to auto increment cell value at specific time intervals, and Stops the procedure on crossing a specific cell value.

'To run a procedure at a specific time, use TimeValue(time) viz. TimeValue("20:30:00") will run a procedure at 8.30 pm. To run a procedure at specified time intervals (say, from now), use Now + TimeValue(time) viz. Now + TimeValue("00:00:15") sets the time interval at 15 seconds, at which interval the procedure will run.

'set the time interval at 15 seconds, at which interval the procedure will run.
    Dim oTbl As ListObject
    Dim oRw As ListRow
    Dim Rws As Integer

    rTime = Now + TimeValue("00:00:15")

    Application.ScreenUpdating = False

    'procedure named CellValueAutoIncr1 will autmatically run, at the sheduled time interval, with the OnTime Method.
    Application.OnTime EarliestTime:=rTime, Procedure:="CellValueAutoIncr1", schedule:=True

    'increment the value in cell A1 (in Active Worksheet) by 1, for each time the Macro is repeated:
    '    Cells(1, 1).Value = Cells(1, 1).Value + 1

    '    Worksheets("Dataload").Select
    '    Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
    '    Worksheets("Pivot").Select
    '    Worksheets("Pivot").PivotTables("Pivottabel1").PivotCache.Refresh
    '
    '    rwInMax = Worksheets("Dagens summerede Data").Range("A1").CurrentRegion.Rows.Count
    '    rwInMax = rwInMax

    With Worksheets("Dagens summerede Data")
        Set oTbl = .ListObjects(1)

       With Worksheets("Pivot")
       Rws = .Range(.Cells(6, 1), .Cells(6, 7).End(xlDown).Offset(-1)).Rows.Count
        .Range(.Cells(6, 1), .Cells(6, 7).End(xlDown).Offset(-1)).Copy oTbl.ListRows(1).Range.Resize(Rws, 7)
             
    End With
    Worksheets("Test").Select

    Application.ScreenUpdating = True

    If Cells(1, 1).Value > 1 Then
        Application.OnTime rTime, "CellValueAutoIncr1", , False
    End If

End Sub

Open in new window

ASKER CERTIFIED SOLUTION
Avatar of Rory Archibald
Rory Archibald
Flag of United Kingdom of Great Britain and Northern Ireland image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Jorgen

ASKER

Hi Roy,

No I will not be copying to an empty tabel. I will do that every morning, but after that, I will get new data every 10 minutes, that should be added below existing data.

regards

Jørgen
Sorry slight amendment to code

Sub CellValueAutoIncr1a()
'This procedure uses the OnTime Method to auto increment cell value at specific time intervals, and Stops the procedure on crossing a specific cell value.

'To run a procedure at a specific time, use TimeValue(time) viz. TimeValue("20:30:00") will run a procedure at 8.30 pm. To run a procedure at specified time intervals (say, from now), use Now + TimeValue(time) viz. Now + TimeValue("00:00:15") sets the time interval at 15 seconds, at which interval the procedure will run.

'set the time interval at 15 seconds, at which interval the procedure will run.
    Dim oTbl As ListObject
    Dim oRw As ListRow
    Dim Rws As Integer

    rTime = Now + TimeValue("00:00:15")

    Application.ScreenUpdating = False

    'procedure named CellValueAutoIncr1 will autmatically run, at the sheduled time interval, with the OnTime Method.
    Application.OnTime EarliestTime:=rTime, Procedure:="CellValueAutoIncr1", schedule:=True

    'increment the value in cell A1 (in Active Worksheet) by 1, for each time the Macro is repeated:
    '    Cells(1, 1).Value = Cells(1, 1).Value + 1

    '    Worksheets("Dataload").Select
    '    Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
    '    Worksheets("Pivot").Select
    '    Worksheets("Pivot").PivotTables("Pivottabel1").PivotCache.Refresh
    '
    '    rwInMax = Worksheets("Dagens summerede Data").Range("A1").CurrentRegion.Rows.Count
    '    rwInMax = rwInMax

    With Worksheets("Dagens summerede Data")
        Set oTbl = .ListObjects(1)
    End With
    With Worksheets("Pivot")
        Rws = .Range(.Cells(6, 1), .Cells(6, 7).End(xlDown).Offset(-1)).Rows.Count
        .Range(.Cells(6, 1), .Cells(6, 7).End(xlDown).Offset(-1)).Copy oTbl.ListRows(1).Range.Resize(Rws, 7)

    End With


    Worksheets("Test").Select

    Application.ScreenUpdating = True

    If Cells(1, 1).Value > 1 Then
        Application.OnTime rTime, "CellValueAutoIncr1", , False
    End If

End Sub

Open in new window

Avatar of Jorgen

ASKER

Hi Roy and Rory,

It seems like both codes Work, but for some reason Roy's code does not seem to Work, which I will look into.

If I have questions regarding the code I will get back to you.

regards

Jørgen
SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Hi,

I have resolved the pasting issue by only copying just before requiring the paste. Full code below.

Option Explicit

'Dim as a Public variable and it will be available to all Procedures in all modules.
Public rTime As Date

Sub CellValueAutoIncr1()

    Dim newRow As ListRow

'This procedure uses the OnTime Method to auto increment cell value at specific time intervals, and Stops the procedure on crossing a specific cell value.
'To run a procedure at a specific time, use TimeValue(time) viz. TimeValue("20:30:00") will run a procedure at 8.30 pm. To run a procedure at specified time intervals (say, from now), use Now + TimeValue(time) viz. Now + TimeValue("00:00:15") sets the time interval at 15 seconds, at which interval the procedure will run.
'set the time interval at 15 seconds, at which interval the procedure will run.
rTime = Now + TimeValue("00:00:15")
Application.ScreenUpdating = False
 
'procedure named CellValueAutoIncr1 will autmatically run, at the sheduled time interval, with the OnTime Method.
Application.OnTime EarliestTime:=rTime, Procedure:="CellValueAutoIncr1", schedule:=True

'increment the value in cell A1 (in Active Worksheet) by 1, for each time the Macro is repeated:
Worksheets("Test").Select
    Cells(1, 1).Value = Cells(1, 1).Value + 1

Worksheets("Dataload").Select
    Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False

Worksheets("Pivot").Select
    Worksheets("Pivot").PivotTables("Pivottabel1").PivotCache.Refresh

' ##### Select the sheet containing the table Tbl_Summarized #####
Worksheets("Dagens summerede Data").Select
    Range("Tbl_Summarized[#Headers]").Select
    Set newRow = Selection.ListObject.ListRows.Add(AlwaysInsert:=True)
    newRow.Range(1, 1).Select
    
Worksheets("Pivot").Select
Worksheets("Pivot").Range("A6").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    
Worksheets("Dagens summerede Data").Select
    ActiveSheet.Paste
    ' Assuming timestamp goes in the eighth column of the table
    newRow.Range.Cells(1, 8).Select
    ' ***** The next line will cause trouble if only a single row was pasted
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormulaR1C1 = Format(Now, "hh:mm:ss")
    
Worksheets("Test").Select

Application.ScreenUpdating = True

If Cells(1, 1).Value > 1 Then

Application.OnTime rTime, "CellValueAutoIncr1", , False

End If

End Sub

Open in new window