code
deze code gebruik om elke sheet aan te roepen en vervolgens via een andere macro de sheet te versturen...
Public Sub CopyWorksheets()
Dim wb As Workbook
Dim i As Integer
Dim j As Integer
Dim newwb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set newwb = Excel.Workbooks.Add
j = 1
For i = 1 To wb.Worksheets.Count
If wb.Worksheets(i).Name <> "MissingPrices" And wb.Worksheets(i).Name <> "mail adressen" Then
wb.Worksheets(i).Activate
Cells.Select
Selection.Copy
If j > 3 Then
Set ws = newwb.Worksheets.Add
Else
Set ws = newwb.Worksheets("Sheet" & j)
End If
ws.Name = wb.Worksheets(i).Name
ws.Activate
ws.Paste
j = j + 1
End If
Application.Run "'MissingPrices wsheet per tp.xls'!Send_Active_Sheet"
Next i
newwb.Close (False)
Set newwb = Nothing
MsgBox "De mails uitgestuurd. ", vbInformation
End Sub
eigenlijk zou ik deze code graag uitgebreid zien om in de sheet met mailadressen
elke firma een mail te versturen waar de firmanaam dezelfde is als de sheet naam...
met onderstaande macro maak ik per firma een sheet aan...-ron de bruin-
Sub Copy_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim FieldNum, N As Integer
'Name of the sheet with your data
Set ws1 = Sheets("missingprices")
N = Range("A65000").End(xlUp).Row - 5
Range("C6").Formula = "=SUBSTITUTE(LEFT(RC2,4),""*"","""")"
Calculate
' doortrekken voor alle ingevulde lijnen
Range("C6").Copy
Range("C6:C" & (5 + N)).PasteSpecial xlPasteFormulas
Calculate
Columns("C:C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, C is the last column in the filter range
Set rng = ws1.Range("A5:C" & Rows.Count)
'Set Field number of the filter column
'This example filters on the first field in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 3
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
' Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add
With ws2
'first we copy the Unique data from the filter field to ws2
rng.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("C6"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "C").End(xlUp).Row
For Each cell In .Range("C6:C" & Lrow)
Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = "MP_" & cell.Value
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0
'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False
'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value
'Copy the visible data and use PasteSpecial to paste to the new worksheet
ws1.AutoFilter.Range.Copy
With WSNew.Range("A5")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
'Close AutoFilter
ws1.AutoFilterMode = False
Range("A1").Formula = "=MissingPrices!RC"
Range("A3").Formula = "=MissingPrices!R[-1]C"
Next cell
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
alvast bedankt!
