Circular references!!! Now there's a thought! but I can't see any
though!! AAARRRGGGHHH!!!

What's strange also is that after the "unsuccesful" paste  that
actually worked the maths is wrong.
For example I have this

B C D E F G
3 Januari Februari
4 Aantal Per stuk Totaal Aantal Per stuk Totaal
5 7.00 2.86 20.00
(B5*C5)

I cut B5:D5 and try to paste it to Feb at E5.
I get this

B C D E F G
3 Januari Februari
4 Aantal Per stuk Totaal Aantal Per stuk Totaal
5 7.00 2.86 20.00
(B5*C5)

With B5*C5 in G5 showing 20!

Let's have the code then....................

Option Explicit
Sub subGetData()
' Do The Biz.

Dim llTopRow As Long
Dim llEndRow As Long
Dim slTopCell As String
Dim slEndCell As String
Dim slCol As String
Dim ilCol As Integer
Dim slRow As String
Dim slR As String
Dim slCols1235 As String
Dim slCols235 As String
Dim slTotalCol1 As String
Dim slCols23 As String
Dim ilTotalRow As Integer
Dim blTotalRow As Boolean
Dim blEmptyRow As Boolean
Dim blDelete As Boolean
Dim olWorkBook As Workbook
Dim slWbookname As String
Dim slActiveSheet As String
Dim sl3Chrs As String
Dim olWorkSheet As Worksheet
Dim slWorkSheetName As String
Dim slActiveWBookName As String
Dim ilMonthRow As Integer
Dim ilRow As Integer
Dim slCols12 As String
Dim slcol3 As String
Dim dlamount As Double
Dim dlqty As Double
Dim dlrate As Double
Dim slQty As String
Dim slMonth As String
Dim olR1 As Range
Dim olR2 As Range

' Where am I?
slActiveSheet = UCase(ActiveSheet.Name)

' Pick up Month.
slMonth = ""
For Each olWorkBook In Workbooks
slWbookname = UCase(olWorkBook.Name)
If InStr(slWbookname, "JAN") > 0 Then
slMonth = "JAN"
Exit For
ElseIf InStr(slWbookname, "JAN") > 0 Then
slMonth = "JAN"
Exit For
ElseIf InStr(slWbookname, "FEB") > 0 Then
slMonth = "FEB"
Exit For
ElseIf InStr(slWbookname, "MAR") > 0 Then
slMonth = "MAA"
Exit For
ElseIf InStr(slWbookname, "APR") > 0 Then
slMonth = "APR"
Exit For
ElseIf InStr(slWbookname, "MAY") > 0 Then
slMonth = "MEI"
Exit For
ElseIf InStr(slWbookname, "JUN") > 0 Then
slMonth = "JUN"
Exit For
ElseIf InStr(slWbookname, "JUL") > 0 Then
slMonth = "JUL"
Exit For
ElseIf InStr(slWbookname, "AUG") > 0 Then
slMonth = "AUG"
Exit For
ElseIf InStr(slWbookname, "SEP") > 0 Then
slMonth = "SEP"
Exit For
ElseIf InStr(slWbookname, "OCT") > 0 Then
slMonth = "OKT"
Exit For
ElseIf InStr(slWbookname, "NOV") > 0 Then
slMonth = "NOV"
Exit For
ElseIf InStr(slWbookname, "DEC") > 0 Then
slMonth = "DEC"
Exit For
End If
Next olWorkBook

' Now we have a month and a workbook name.
subCopyDataToTemp slWbookname
subFormatAtoF
subDel1
subGoToEndTotalRow
ilTotalRow = ActiveCell.Row

' From here start to delete blank rows.
For llEndRow = ilTotalRow To 1 Step -1

' Make sure of the active cell.
Cells(llEndRow, 1).Select

slCols1235 = _
Trim(ActiveCell.Text) _
& Trim(ActiveCell.Offset(0, 1).Text) _
& Trim(ActiveCell.Offset(0, 2).Text) _
& Trim(ActiveCell.Offset(0, 4).Text) _

slCols235 = _
Trim(ActiveCell.Offset(0, 1).Text) _
& Trim(ActiveCell.Offset(0, 2).Text) _
& Trim(ActiveCell.Offset(0, 4).Text)

slCols23 = _
Trim(ActiveCell.Offset(0, 1).Text) _
& Trim(ActiveCell.Offset(0, 2).Text)

slCols12 = _
Trim(ActiveCell.Text) _
& Trim(ActiveCell.Offset(0, 1).Text)

slTotalCol1 = _
Trim(ActiveCell.Text)

slcol3 = _
Trim(ActiveCell.Offset(0, 2).Text)

slCols1235 = UCase(slCols1235)
slCols235 = UCase(slCols235)
slCols23 = UCase(slCols23)
slTotalCol1 = UCase(slTotalCol1)
slcol3 = UCase(slcol3)
slCols12 = UCase(slCols12)

blDelete = False
Do

' Cols 1,2,3,4 blank.
If slCols1235 = "" Then
blDelete = True
Exit Do
End If

' Cols 2,3,4 blank.
If slCols235 = "" Then
blDelete = True
Exit Do
End If

' Cols 2,3 blank and Total in Col1,
If slCols23 = "" Then
If InStr(slTotalCol1, "TOTAL") > 0 Then
blDelete = True
Exit Do
End If
End If

' Cols 2,3 blank.
If slCols23 = "" Then

' Move stuff around.
ActiveCell.Offset(0, 4).Copy
ActiveCell.Offset(0, 2).PasteSpecial
ActiveCell.Offset(0, -2).Select
ActiveCell.Offset(0, 1).FormulaR1C1 = "1"
Exit Do

End If

If slcol3 = "" Then

dlamount = ActiveCell.Offset(0, 4).Value
dlqty = ActiveCell.Offset(0, 1).Value
dlrate = dlamount / dlqty
ActiveCell.Offset(0, 2).Value = dlrate
Exit Do

End If

Exit Do
Loop

If blDelete Then
Rows(llEndRow).Select
Selection.Delete Shift:=xlDown

Else

' Fill in the "Total" column.
ActiveCell.Offset(0, 3).FormulaR1C1 = "=RC[-2]*RC[-1]"

End If

If ActiveCell.Row = 1 Then
Exit For
End If

Next llEndRow

subInsertComparison
subFormatAtoF
Worksheets(slActiveSheet).Activate
subInsertNewMonth

' Top Left Cell of Paste.
' Should be in col A.
Set olR1 = ActiveCell
ilRow = olR1.Row

' Where to move it to?
' Where is the month col?
Range("A1").Select
Do
If UCase(ActiveCell.Text) = "MAAND" Then
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
Do
If InStr(UCase(ActiveCell.Text), slMonth) > 0 Then
Exit Do
Else
ActiveCell.Offset(0, 1).Select
End If
Loop

ActiveCell.Offset(0, ActiveCell.Column - 1).Select
ilCol = ActiveCell.Column

Cells(ilRow, ilCol).Select

olR1.Offset(0, 2).Select
Range(ActiveCell, ActiveCell.Offset(0, 2)).Select
Range(Selection, Selection.End(xlDown)).Select

Selection.Cut
olR2.Select
ActiveSheet.Paste ' <<<<<<<<<<<<Problem here!
'Selection.PasteSpecial _
Paste:=xlValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False


'
**********************************************************************
******
End Sub
Sub subDel1()
' Initial delete of unwanted rows.

' Get Month.

Rows("1:4").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Columns("A:C").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.Insert Shift:=xlToRight

'
**********************************************************************
******
End Sub
Sub subGoToEndTotalRow(Optional ipStartRow As Variant)
' Go way down and move up till we hit "TOTAL".

Dim ilTotalRow As Integer
Dim llEndRow As Long
Dim slCellTest As String
Dim ilStartRow As Integer

If IsMissing(ipStartRow) Then
ilStartRow = 200
Else
ilStartRow = ipStartRow
End If

Range("a" & ilStartRow).Select
ilTotalRow = 0
For llEndRow = ilStartRow To 1 Step -1
slCellTest = ActiveCell.Text _
& ActiveCell.Offset(0, 1).Text _
& ActiveCell.Offset(0, 2).Text _
& ActiveCell.Offset(0, 3).Text _
& ActiveCell.Offset(0, 4).Text
If slCellTest <> "" Then
If InStr(slCellTest, "TOTAL") > 0 Then
ilTotalRow = llEndRow
Exit For
End If
End If
If ActiveCell.Row > 1 Then
ActiveCell.Offset(-1, 0).Select
End If
Next llEndRow
'
**********************************************************************
******
End Sub
Sub subInsertComparison()
' Set RED for not equal.

Dim rlRange As Range

Cells.Select
Selection.FormatConditions.Delete

Range("e1").Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add _
Type:=xlCellValue, _
Operator:=xlNotEqual, _
Formula1:="=D1"
Selection.FormatConditions(1).Font.ColorIndex = 3
Selection.Copy

Range("e2").Select
Range(Selection, Selection.End(xlDown)).Select

Selection.PasteSpecial _
Paste:=xlFormats, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

'
**********************************************************************
******
End Sub
Sub subInsertNewMonth()
' Insert a new month from Temp.

Dim slSheetName As String
Dim slActiveSheet As String
Dim sl3Chrs As String
Dim olWorkSheet As Worksheet
Dim slWorkSheetName As String

' What's this sheet name?
slActiveSheet = UCase(ActiveSheet.Name)
sl3Chrs = UCase(Mid(slActiveSheet, 1, 3))

For Each olWorkSheet In Worksheets
slWorkSheetName = UCase(olWorkSheet.Name)
If Mid(slWorkSheetName, 1, 4) = "TEMP" Then
If InStr(slWorkSheetName, sl3Chrs) > 0 Then
olWorkSheet.Activate
Range("a1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 3).Select
Range(ActiveCell, "a1").Select
Selection.Copy
Worksheets(slActiveSheet).Activate
subGoToInsertRow
Selection.PasteSpecial _
Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Exit For
End If
End If
Next olWorkSheet
'
**********************************************************************
******
End Sub
Sub subGoToInsertRow()
' Go way down and back up to paste.

Range("a1").Select
Do
Selection.End(xlDown).Select
If ActiveCell.Row > 65000 Then
Exit Do
End If
Loop
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
'
**********************************************************************
******
End Sub
Sub subCopyDataToTemp(spWBook As String)
' Go to the correct sheet.

Dim slSheetName As String
Dim slActiveSheet As String
Dim sl3Chrs As String
Dim olWorkSheet As Worksheet
Dim slWorkSheetName As String
Dim slActiveWBookName As String

slActiveSheet = UCase(ActiveSheet.Name)
sl3Chrs = UCase(Mid(slActiveSheet, 1, 3))
slActiveWBookName = ActiveWorkbook.Name

Workbooks(spWBook).Activate
For Each olWorkSheet In Worksheets
slWorkSheetName = UCase(olWorkSheet.Name)
If InStr(slWorkSheetName, sl3Chrs) > 0 Then
olWorkSheet.Activate
Exit For
End If
Next olWorkSheet

Cells.Select
Selection.Copy
Workbooks(slActiveWBookName).Activate
For Each olWorkSheet In Worksheets
slWorkSheetName = UCase(olWorkSheet.Name)
If Mid(slWorkSheetName, 1, 4) = "TEMP" Then
If InStr(slWorkSheetName, sl3Chrs) > 0 Then
olWorkSheet.Activate
Cells.Select
Selection.PasteSpecial _
Paste:=xlValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Exit For
End If
End If
Next olWorkSheet

'
**********************************************************************
******
End Sub
Sub subFormatAtoF()

Columns("A:F").Select
Columns("A:F").EntireColumn.AutoFit
Columns("B:F").Select
Selection.NumberFormat = "0.00"
Range("A1").Select
Application.CutCopyMode = False


'
**********************************************************************
******
End Sub

I maaaay have an answer to this. I'm testing it now. I got to a lot of
this code by recording.. don't we all :-)

So.. I thought maybe some of that is screwing up. So far I've had
succsess in removing the line from the recorded stuff that reads
"Application.CutCopyMode = False".

I've trimmed this post because of it's size... the code is in a
previous post.

As I said I'm still testing but I think that's it but I will get back
and say for def.
Curiously enough... at site
msdn.microsoft.com/.../vbaxl
11/html/xlproCutCopyMode1_HV05200342.asp

I see there are 2 values TRUE and FALSE for CutCopyMode.
Guess what they say...

False Cancels Cut or Copy mode and removes the moving border.
True Cancels Cut or Copy mode and removes the moving border.

I think the problem  arises from trying to cut and pasteSpecial rather
than copy and paste  special. If you try to cut and pasteSpecial in the
spreadsheet manually you'll find it doesn't offer the option to
PasteSpecial when you've cut rather than copied.

I think the quick answer is to go back and delete the copied cells
after PasteSpecial, but since that operation changes the selection
you'd have to reselct them..

So since you're just copying values how about:

Range(olR2, olR2.Offset(Selection.Rows.Count - 1, _
Selection.Columns.Count - 1)) = Selection.Value
Selection.Clear

This leaves the selected cells as the cleared cells on the sheet
copied from.

I've tried paste  and pastespecial and lots of other things as well and
everything fails on that paste. I either get a 1004 error or a
80010108 error. Researching them on the net leads me to think it may
be a late/early binding problem  and that VBA is just getting lost
somewhere.

I'm going to try and fully qualify stuff but if that doesn't work I
want to be able to close and open the workbook. Any idea how I can do
that please??

I'ts fixed!!

support.microsoft.com/default.aspx

I'm still trying things so you got a bit of code that
isn't .. erm... correct.

Here is the "real" end bit.

Loop

'ActiveCell.Offset(0, ActiveCell.Column - 1).Select
ilCol = ActiveCell.Column

Cells(ilRow, ilCol).Select
Set olR2 = ActiveCell

olR1.Offset(0, 1).Select
Range(ActiveCell, ActiveCell.Offset(0, 2)).Select
Range(Selection, Selection.End(xlDown)).Select

Selection.Cut
olR2.Select
'ActiveSheet.Paste
Selection.PasteSpecial _
Paste:=xlValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

End Sub