Code export aanpassen

Status
Niet open voor verdere reacties.
Zoiets?
Code: 
Sub ExportLabels2017() 'hsv
Dim Sh As Worksheet, sn, sp, st, j As Long, c00 As String
Application.ScreenUpdating = False


With GetObject(ThisWorkbook.Path & "\ImportLabels.xls")
.Windows(1).Activate
  With .Sheets("2017Labels")
  .Range("A2:A2500").Clear
  .Range("F2:F2500").Clear
  .Range("G2:G2500").Clear
  .Range("H2:H2500").Clear
  For Each Sh In ThisWorkbook.Sheets
        If Len(Sh.Name) = 9 Then
 sn = Sh.Range("B22:H" & Application.Max(22, Sh.Cells(123, 2).End(xlUp).Row))
 sp = Sh.Range("B236:U" & Application.Max(236, Sh.Cells(123, 2).End(xlUp).Row + 214))
      For j = 1 To UBound(sn)
        c00 = c00 & Replace(String(sn(j, 7), " "), " ", " " & j)
      Next
      
    If c00 <> "" Then
       st = Application.Transpose(Split(Trim(c00)))
      .Cells(Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 1).Resize(UBound(st)) = Application.Index(sn, st, 1)
      .Cells(Application.Max(2, .Cells(Rows.Count, 6).End(xlUp).Offset(1).Row), 6).Resize(UBound(st)) = Application.Index(sn, st, 7)
      .Cells(Application.Max(2, .Cells(Rows.Count, 7).End(xlUp).Offset(1).Row), 7).Resize(UBound(st)) = Sh.Name
      .Cells(Application.Max(2, .Cells(Rows.Count, 8).End(xlUp).Offset(1).Row), 8).Resize(UBound(st)) = Application.Index(sp, st, 20)
    End If
 End If
c00 = ""
Next Sh
End With
End With
End Sub
 
Laatst bewerkt:
Code geeft geen foutmelding.

Wat me wel opvalt, is dat er ergens een verschuiving optreedt ?
wat als resultaat geeft, dat van kolom H in importlabels op het einde 11 lege cellen geeft

ik had als voorbeeld 2 tabbladen een "soldenprijs" ingegeven, en daar ook maakt hij de fout van 11 rijen ...

Nog een testje gedaan waar maar 2 artikelen in tabblad staan, vul soldenprijs in, en geeft hij ook niet terug na export

heb code proberen te ontleden, en klopt toch U236 .....

harry, op wat slaat die + 214 ?

Als ik 214 verminder met 11, dus 203 plaats, komen de rijen wel overeen, maar krijg ik om onverklaarbare reden bij sommige cellen de foutmelding #verw!
 
Laatst bewerkt:
De 214 stond een haakje te vroeg.
Code: 
sp = Sh.Range("B236:U" & Application.Max(22, Sh.Cells(123, 2).End(xlUp).Row) + 214)
 
en toch blijf er ergens een sprong van 11 gemaakt worden, code plaatst de soldenprijs 11 rijen te hoog, en daardoor zijn de laatste 11 cellen op kolom H leeg
 
Hier niet.
Als B236 = B22
Als B248 = B34
 
HSV zei:
Hier niet.
Als B236 = B22
Als B248 = B34
Klik om te vergroten...

klopt hier ook
laatste is
B337 = B123

zit dus altijd 214 tussen .....
Anders moet ik sheet per sheet nakijken of er ergens een VERKEERDE tussen zit, kan dit ?
 
Laatst bewerkt:
Klopt, waar het fout gaat bij jou weet ik zo niet.
Hier wordt kolom H netjes gevuld zonder verschuiving tot de laatste rij van kolom A.
 
HSV zei:
Klopt, waar het fout gaat bij jou weet ik zo niet.
Hier wordt kolom H netjes gevuld zonder verschuiving tot de laatste rij van kolom A.
Klik om te vergroten...

Normaal kan er geen fout in zitten, want is altijd een basisxlt ingevoegd, maar ik ga blad voor blad nakijken dan, pffff een gans werk, maar kan niet anders vrees ik
 
er liep iets fout in de kolom solden op het inkoopboek met een formule, was iets dat ik gisteren had aangepast, heb dat formuleke weggenomen , en nu doet hij alles PERFECT :thumb:

Als het kan en mag, de laatste vraag ivm export

kunnen we in de code ergens opnemen dat de data van 2016 naar labels2016 gaat, en de data van 2017 naar labels2017
we kijken nu naar sh.lengte (9), kan daar op een of andere manier gekeken worden in de lengte9 naar 2016 of 2017 ?

Nu wordt de etiketlijst veel te lang, als we dat per jaar kunnen opsplitsen, zou handiger zijn
 
Code: 
Sub ExportLabels2017() 'hsv
Dim Sh As Worksheet, sn, sp, st, j As Long, c00 As String
Application.ScreenUpdating = False


With GetObject(ThisWorkbook.Path & "\ImportLabels.xls")
.Windows(1).Activate
  With .Sheets("2017Labels")
  .Range("A2", .Range("A2").End(xlDown)).Clear
  .Range("F2", .Range("F2").End(xlDown)).Resize(, 3).Clear
  End With
  With .Sheets("2016Labels")
  .Range("A2", .Range("A2").End(xlDown)).Clear
  .Range("F2", .Range("F2").End(xlDown)).Resize(, 3).Clear
  End With
  
  For Each Sh In ThisWorkbook.Sheets
        If Len(Sh.Name) = 9 Then
 sn = Sh.Range("B22:H" & Application.Max(22, Sh.Cells(123, 2).End(xlUp).Row))
 sp = Sh.Range("B236:U" & Application.Max(22, Sh.Cells(123, 2).End(xlUp).Row) + 214)
      For j = 1 To UBound(sn)
        c00 = c00 & Replace(String(sn(j, 7), " "), " ", " " & j)
      Next
      
    If c00 <> "" Then
      With .Sheets(Mid(Sh.Name, 5, 4) & "Labels")
       st = Application.Transpose(Split(Trim(c00)))
      .Cells(Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 1).Resize(UBound(st)) = Application.Index(sn, st, 1)
      .Cells(Application.Max(2, .Cells(Rows.Count, 6).End(xlUp).Offset(1).Row), 6).Resize(UBound(st)) = Application.Index(sn, st, 7)
      .Cells(Application.Max(2, .Cells(Rows.Count, 7).End(xlUp).Offset(1).Row), 7).Resize(UBound(st)) = Sh.Name
      .Cells(Application.Max(2, .Cells(Rows.Count, 8).End(xlUp).Offset(1).Row), 8).Resize(UBound(st)) = Application.Index(sp, st, 20)
     End With
    End If
 End If
c00 = ""
Next Sh
End With
End Sub
 
Laatst bewerkt:
Harry,

je code even laten lopen

voor tabblad 2017labels werkt hij perfect
op tabblad 2016labels loopt hij vast ! op de volgende lijn
Code: 
With .Sheets(Mid(Sh.Name, 5, 4) & "Labels")

Is er ook geen verandering naar het verwijderen van reeds geplaatste data, ik bedoel daarmee het volgende
Code: 
.Range("A2:A2500").Clear
  .Range("F2:F2500").Clear
  .Range("G2:G2500").Clear
  .Range("H2:H2500").Clear

Ik vermoed dat je nu enkel range A en F doet, misschien zit daar de fout ?
 
Dan heb je geen tabblad 2016Labels in je bestand staan.

Ik heb aangenomen dat een sh.name bestaat uit 8 cijfers + een letter. bv. (02032016A)
Ik doe met de resize(,3) 3 kolommen tegelijk (F, G,en H).
 
Laatst bewerkt:
had de fout juist gevonden, was een tabblad met een verkeerde naam/ code tussengeraakt, heb deze aangepast en werkt nu prima voor 2017 & 2016

ga nog even verder om alles in de definitieve omgeving te plaatsen, bedankt alvast en laat nog bericht over de voortzetting :thumb::thumb:

Tom
 
Goedenavond harry :thumb::thumb::thumb:

net alles naar productie geplaatst en alles overgebracht, was een gans werk, maar nu is het FORMIDABEL

Enkel qua lay-out, had ik graag alle data in Font Calibri size 16 geplaatst
En bij de soldenprijs zou het € niet mee genomen mogen worden.

Slaapwel

Tom
 
Code: 
With .Sheets(Mid(Sh.Name, 5, 4) & "Labels")
[COLOR=#0000ff]      .UsedRange.Font.Size = 16[/COLOR]
       st = Application.Transpose(Split(Trim(c00)))
      .Cells(Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 1).Resize(UBound(st)) = Application.Index(sn, st, 1)
      .Cells(Application.Max(2, .Cells(Rows.Count, 6).End(xlUp).Offset(1).Row), 6).Resize(UBound(st)) = Application.Index(sn, st, 7)
      .Cells(Application.Max(2, .Cells(Rows.Count, 7).End(xlUp).Offset(1).Row), 7).Resize(UBound(st)) = Sh.Name
      .Cells(Application.Max(2, .Cells(Rows.Count, 8).End(xlUp).Offset(1).Row), 8).Resize(UBound(st)) = Application.Index(sp, st, 20)
[COLOR=#0000ff]      .Columns(8).Replace "€ ", ""[/COLOR]
     End With
 
Perfect !
heb ook nog Font.Bold = true toegevoegd :)

Vanavond is een van onze consumentes op baan geweest, met het programmake factuurbarcode
Werkte volledig perfect (enkel bij mailen kreeg ze een foutmelding, ook al was ze verbonden met internet)
ze kreeg een foutmelding op deze regel zei ze
Code: 
ActiveSheet.ExportAsFixedFormat 0, c00

Maar iets heel raar is volgende het opslagen van de facturen werkt NIET meer !
En er is niks veranderd aan de code of aan de mappen, heb al vanalles geprobeerd maar wil geen PDF meer opslaan, krijg ook geen foutmelding, niks, niks
Het rare is dat om 19 uur, nog 1 factuur is opgeslagen vanop de verkoopplaats van de consulente
Alle facturen zijn mooi aangemaakt en opgeslagen

We delen wel alles via dropbox, kan daar iets verkeerd lopen ?

Wat kunnen pc's en programma's toch raar zijn he

update: ik denk dat ik in factuurbarcode een datumconflict heb veroorzaakt, ik wacht tot morgen om nog eens proberen op te slaan
 
Laatst bewerkt:
Gedeelde bestanden en Vba gaan niet altijd goed.
Zoek maar eens op het web.
 
oeps das minder goed nieuws, ga eens surfen op net dan .....

mag ik dan alle mappen van dropbox verplaatsen naar mijn c schijf ?
heeft dit invloed op mijn path voor de codes ?
 
Ik heb alleen maar codes geschreven voor 'Thisworkbook.Path' volgens mij.
Doe direct geen rigoureuze dingen.
Kijk eens op de site van JKP (Jan Karel Pieterse) over gedeelde bestanden.
 
bedoel maar bv het volgende

Code: 
c00 = "C:\Users\tombe_000\Dropbox\EsFashionCloset\FacturenHomePartys\EH " & Format(Date, "dd-mm-yyyy") & " " & Sh.Range("F6") & " " & Sh.Range("D5") & ".pdf"

Als ik nu alles ga verplaatsen, vrees ik dat ik alles moet aanpassen :)

Ik ga eerst wachten tot morgen maar begrijp hier echt niks van, dat die facturen nu nie willen opslaan, heb hier al vanalles geprobeerd en maar krijg er niks uit, hetgeen me ergert is dat ik geen foutmelding krijg

Code: 
Sub PdfOpslaan()
Dim Sh As Worksheet, c00 As String
 For Each Sh In Sheets
 If Len(Sh.Name) = 10 Then
    c00 = "C:\Users\tombe_000\Dropbox\EsFashionCloset\FacturenHomePartys\EH " & Format(Date, "dd-mm-yyyy") & " " & Sh.Range("F6") & " " & Sh.Range("D5") & ".pdf"
    If InStr(c00, Sh.Name) = 0 Then Sh.ExportAsFixedFormat 0, c00
  End If
  
  Next Sh
End Sub

Ga ook even op de site van JPK lezen, thx voor de tip alvast
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan