• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Aanpassen code voor server 2012R2

  • Onderwerp starter Onderwerp starter HWV
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.
HWV

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

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:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan