stefano
Gebruiker
- Lid geworden
- 22 mei 2004
- Berichten
- 860
In een macro worden data gekopieerd en geplakt. Ik stel vast dat die data op het klembord actief zijn/blijven. Ik gebruik nochthans hier en daar application.cutcopymode : false
Waarom wordt het klembord niet gewist?
- macro 1
-macro 2
in bovenstaande code wordt een derde macro opgeroepen (rijensamenvoegen)
Waarom wordt het klembord niet gewist?
- macro 1
Code:
Sub macro_vandaag()
Call HM2("TOV", "Tarweontvangsten vandaag")
End Sub
-macro 2
Code:
Sub HM2(FN As String, NFN As String)
Dim rijen As Integer
' 1. indien eindbestand open staat, afsluiten
Dim Wb As Workbook
On Error Resume Next
Set Wb = Workbooks(NFN & ".xlsm")
If Err.Number = 0 Then
MsgBox "Bestand " & Wb.Name & " staat nog open, dit wordt afgesloten zonder opslaan"
Wb.Close
End If
' 1. einde afsluiten
Application.DisplayAlerts = False
Workbooks.OpenText Filename:="C:\data\sap\" & FN & "_1" & ".xls"
Cells.Copy
Application.Goto [A1]
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
[COLOR="#FF0000"] Application.CutCopyMode = False[/COLOR]
Columns("Y:IV").Select
Selection.NumberFormat = "0.000"
Application.Goto [A1]
Application.Run "RIJENSAMENVOEGEN"
Workbooks.Open Filename:="C:\data\sap\" & FN & "_2" & ".xlsm"
Workbooks(FN & "_2" & ".xlsm").Activate
rijen = Cells(Rows.Count, 1).End(xlUp).Row
Rows("8" & ":" & rijen).Copy
Range("A8").PasteSpecial xlPasteValues
[COLOR="#FF0000"] Application.CutCopyMode = False[/COLOR]
Application.Goto [A1]
Workbooks(FN & "_2" & ".xlsm").SaveAs "C:\data\sap\" & NFN
Workbooks(FN & "_1" & ".xls").Close False
Application.DisplayAlerts = True
End Sub
in bovenstaande code wordt een derde macro opgeroepen (rijensamenvoegen)
Code:
Sub RIJENSAMENVOEGEN()
' error inbouwen wanneer er nog geen ontvangsten zijn
On Error GoTo Err1:
Dim i As Long, x As Long
Dim ii As Integer
Dim T1 As Variant
Const lSC As Long = 2 'regelnummer van de startcel
T1 = Cells(lSC, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - (lSC - 1), 256)
ReDim T2(1 To 256, 1 To 1)
For i = 1 To 256
T2(i, 1) = T1(1, i)
Next i
x = 1
For i = 2 To UBound(T1, 1)
If T1(i, 1) = T1(i - 1, 1) Then
For ii = 1 To 256
If Replace(T1(i, ii), " ", "") <> "" Then T2(ii, x) = T1(i, ii)
Next ii
Else
x = x + 1
ReDim Preserve T2(1 To 256, 1 To x)
For ii = 1 To 256
T2(ii, x) = T1(i, ii)
Next ii
End If
Next i
With Sheets.Add(after:=Sheets(ActiveSheet.Index))
With .Previous
.Range("A1:IV1").Copy Cells(1, 1)
.Cells.Copy
End With
.Cells.PasteSpecial xlPasteFormats
.Cells(2, 1).Resize(UBound(T2, 2), 256) = WorksheetFunction.Transpose(T2)
.Cells(1, 1).Select
End With
[COLOR="#FF0000"] Application.CutCopyMode = False[/COLOR]
Err1:
End Sub