HWV
Terugkerende gebruiker
- Lid geworden
- 19 feb 2009
- Berichten
- 1.213
Bekijk bijlage Helpmij.rar
Beste,
Ik werk met afname kaarten, die elke nacht moeten draaien op onze server.
Nu hebben wij sinds een maand een nieuwe server maar mijn code loopt daar vast, op de lange versie. Dus met originele bestanden afname 2015 en 2016 zijn van 400 klanten
Als hij de mappen heeft gemaakt en dan de afnamekaarten gaat naken gaan er ongeveer 50 wel goed, maar daarna geef hij de melding dat hij het bestand afnamekaart niet kan openen.
Hij geef aan dat er dan geen verbinding gemaakt kan worden met de server elke keer als hij de afnamekaart.xlsx wil openen.
Is er een mogelijkheid de code zo om te bouwen dat afname openblijf staan zodat deze niet telkens geopend hoef te worden.
in de bijlage vind je alle bestanden die we nodig hebben om deze script te laten draaien.
Opvragen Afname Kaart is zo ingesteld dat hij gelijk de code laat lopen zodra deze geopend wordt, (heb ik nodig om de taak te laten draaien op onze server)
Het is een hoop script en weet dat het niet de netste code is maar werkt wel als je deze laat lopen. Deze code is mede opgesteld door de mensen van het form en met name SNB.
(misschien is er wel een hele andere manier om tot dit resultaat te komen)
Alvast dank voor de hulp
Beste,
Ik werk met afname kaarten, die elke nacht moeten draaien op onze server.
Nu hebben wij sinds een maand een nieuwe server maar mijn code loopt daar vast, op de lange versie. Dus met originele bestanden afname 2015 en 2016 zijn van 400 klanten
Als hij de mappen heeft gemaakt en dan de afnamekaarten gaat naken gaan er ongeveer 50 wel goed, maar daarna geef hij de melding dat hij het bestand afnamekaart niet kan openen.
Hij geef aan dat er dan geen verbinding gemaakt kan worden met de server elke keer als hij de afnamekaart.xlsx wil openen.
Is er een mogelijkheid de code zo om te bouwen dat afname openblijf staan zodat deze niet telkens geopend hoef te worden.
in de bijlage vind je alle bestanden die we nodig hebben om deze script te laten draaien.
Opvragen Afname Kaart is zo ingesteld dat hij gelijk de code laat lopen zodra deze geopend wordt, (heb ik nodig om de taak te laten draaien op onze server)
Het is een hoop script en weet dat het niet de netste code is maar werkt wel als je deze laat lopen. Deze code is mede opgesteld door de mensen van het form en met name SNB.
(misschien is er wel een hele andere manier om tot dit resultaat te komen)
Alvast dank voor de hulp
Code:
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Sub KlantenSplitsenAfnameKaart()
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
Dim c As Range
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim sh As Object
On Error Resume Next
Workbooks.Open filename:="H:\Helpmij\GST1- Eenheden1.xls"
Workbooks.Open filename:="H:\Helpmij\901-Artikelen ZNP incl voorraad.xls"
'maak de map waar de bestanden in staan leeg voor de verse bestanden
On Error Resume Next
Kill ("H:\Helpmij\AfnameKaarten\*.*")
bestandenSamenvoegen 'starten macro twee jaren importeren en sorteren
Columns(1) = Columns(15).Value
Set ws1 = ThisWorkbook.Worksheets("Blad1")
For Each c In ws1.Range("A2", ws1.Range("A" & Rows.Count).End(xlUp))
If WksExists(c.Text) Then
Set ws = ThisWorkbook.Worksheets(c.Text)
Else
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = c.Text
End If
c.Resize(, 18).Copy ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
Next
ws1.Select
For Each sh In ThisWorkbook.Sheets
If sh.Index > "" Then
Sheets(sh.Name).Select
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Blad1").Delete
Application.DisplayAlerts = True
''AfnamekaartMaken 'komt een actie te staan
'========================================================================================
On Error Resume Next
Windows("Opvragen Afname kaart.xlsm").Activate
Sheets(sh.Name).Select
Dim lastrow As Long
lastrow = Cells(Rows.Count, 4).End(xlUp).Row
Range("A2:Z" & lastrow).Sort key1:=Range("D2:Z" & lastrow), _
order1:=xlAscending, Header:=xlNo
On Error Resume Next
Workbooks.Open filename:="H:\Helpmij\Afnamekaart.xlsx"
Windows("Opvragen Afname kaart.xlsm").Activate
Sheets(sh.Name).Select
Range("B1:N10000").Select
Selection.Copy
Windows("Afnamekaart.xlsx").Activate
Sheets("Export").Select
Range("B1").Select
ActiveSheet.Paste
Range("B1").Select
Windows("Afnamekaart.xlsx").Activate
Sheets("Import").Select
Range("A2:A1000").Select
Selection.ClearContents
UniekeArtikels
Windows("Afnamekaart.xlsx").Activate
Sheets("Export").Select
Range("A2:A1000").Select
Selection.Copy
Sheets("Import").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'voorraad plaatsen en omschrijving
sn = Sheets("import").Cells(1).CurrentRegion.Resize(, 19)
sp = Workbooks("901-Artikelen ZNP incl voorraad.xls").Sheets("Data1").Cells(1).CurrentRegion
sp1 = Workbooks("GST1- Eenheden1.xls").Sheets("Artikelen").Cells(1).CurrentRegion
For j = 3 To UBound(sn)
For jj = 1 To UBound(sp1)
If Trim(LCase(sn(j, 1))) = Trim(LCase(sp1(jj, 1))) Then Exit For
Next
If jj <= UBound(sp1) Then
sn(j, 2) = sp1(jj, 7)
End If
Next
For j = 3 To UBound(sn)
For jj = 1 To UBound(sp)
If Trim(LCase(sn(j, 1))) = Trim(LCase(sp(jj, 1))) Then Exit For
Next
If jj <= UBound(sp) Then
sn(j, 18) = sp(jj, 6)
sn(j, 19) = sp(jj, 15)
End If
Next
Sheets("import").Cells(1).CurrentRegion.Resize(, 19) = sn
Columns("A:S").Select
Selection.Copy
Windows("Opvragen Afname kaart.xlsm").Activate
Sheets(sh.Name).Select
Range("A1").Select
Sheets(sh.Name).Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
Workbooks("Afnamekaart.xlsx").Close False
'========================================================================================
Opmaak 'opmaak van de pagina maken
[A1] = ""
[A2] = "Artikel"
Range("A3:A300").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
Next sh
For Each ws In ThisWorkbook.Worksheets
Sheets(ws.Name).Select
Sheets(ws.Name).Copy
ActiveWorkbook.SaveAs filename:= _
"H:\Helpmij\AfnameKaarten\" & ws.Name & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close SaveChanges:=True
ThisWorkbook.Activate
Next
Workbooks("901-Artikelen ZNP incl voorraad.xls").Close False
Workbooks("GST1- Eenheden1.xls").Close False
ActiveWorkbook.Saved = True
Application.Quit
End Sub
Sub bestandenSamenvoegen()
'Bestanden samenvoegen
'Kolom M datum veld maken
'Sorteren op debiteurennummer, zodat deze per jaar per debiteur onder elkaar staan.
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Workbooks.Open filename:="H:\Helpmij\afname2015.xls"
With Columns("D:D")
Sheets("Data1").Cells.Replace "=", ""
Sheets("Data1").Cells.Replace """", ""
End With
Workbooks.Open filename:="H:\Helpmij\afname2016.xls"
With Columns("D:D")
Sheets("Data1").Cells.Replace "=", ""
Sheets("Data1").Cells.Replace """", ""
End With
Workbooks("afname2015.xls").Sheets("Data1").Range("A2:S50000").Copy
Workbooks("Opvragen Afname kaart.xlsm").Sheets("blad1").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Workbooks("afname2016.xls").Sheets("Data1").Range("A2:S50000").Copy
Workbooks("Opvragen Afname kaart.xlsm").Sheets("blad1").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Workbooks("afname2015.xls").Close False
Workbooks("afname2016.xls").Close False
Columns("A:S").Select
ActiveWorkbook.Worksheets("Blad1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Blad1").Sort.SortFields.Add Key:=Range("P2:P150044" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Blad1").Sort
.SetRange Range("A1:S150044")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Columns("F:F").Delete
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub UniekeArtikels()
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Windows("Afnamekaart.xlsx").Activate
Sheets("Export").Select
Application.ScreenUpdating = False
MakeExNeg
On Error Resume Next
[uArtikel].ClearContents
For Each cl In [DataExportArtikel]
If InStr(c01, UCase(cl.Value)) = 0 Then c01 = c01 & UCase(cl.Value) & "|"
Next
Range("a2").Resize(UBound(Split(c01, "|")) + 1, 1).Value = WorksheetFunction.Transpose(Split(c01, "|"))
[uArtikel].Sort key1:=Range("A2")
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub MakeExNeg()
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Windows("Afnamekaart.xlsx").Activate
On Error Resume Next
With Sheets("Export")
For Each cl In [DataExportAantal]
If cl.Offset(0, -3).Value = UCase("C") And cl.Value > 0 Then cl.Value = cl.Value * (-1)
Next
End With
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub Opmaak()
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Columns("A:A").Select
With Selection
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1").Select
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = "$2:$2"
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "Afnamekaart"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "Pagina &P van &N"
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.31496062992126)
.RightMargin = Application.InchesToPoints(0.31496062992126)
.TopMargin = Application.InchesToPoints(0.551181102362205)
.BottomMargin = Application.InchesToPoints(0.551181102362205)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 10
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
Application.PrintCommunication = True
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Laatst bewerkt: