• 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.

Gevens uit verschillende kollomen

Status
Niet open voor verdere reacties.
Heb je wel een kolom ingevoegd voor kolom A en daar een aantal X-en in gezet?
 
Dat heb ik inderdaad gedaan. Het filter lijkt in de verkeerde kolom te staan. Alleen in de code staat er wel kolom 1.
1719832703858.png
 
Bestaand filter uit- en weer aanzetten, kolom A was niet in jouw filter opgenomen.
 
Sorry ik begreep het niet goed. Ik heb het filter uit gezet en weer aan. Nu werkt het.
Kun jij mij ook laten zien hoe ik de gegevens in een bestaand excel sheet krijg? zie bijlage.
 

Bijlagen

Je bestand "Aanvraag Template V2.xlsm" is corrupt, de 1048755 lege rijen laten zich niet verwijderen, ik heb daarom een nieuw werkblad toegevoegd met daarin de oorspronkelijke kopregel en het oude werkblad verwijderd. Bestand ging van 2606 kB naar 23 kB, meer dan 100 keer zo klein dus.
Probeer dit eens, kan het zelf niet testen omdat ik niet bij het gekoppelde bestand kan. Wijzig indien nodig ThisWorkbook.Path.
Code: 
Sub ExportBlanks()
    Dim r As Long
    r = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    ActiveSheet.Range("$A$10:$AI$" & r).AutoFilter Field:=1, Criteria1:="X"
    r = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    Range(Replace("F11:F#,G11:G#,K11:K#,N11:N#", "#", r)).Copy
    Workbooks.Open Filename:=ThisWorkbook.Path & "\Aanvraag Template V2.xlsm"
    ActiveSheet.Range("A2").Paste ActiveSheet.Paste
    Cells.EntireColumn.AutoFit
End Sub
 
Bedankt, ik was ondertussen zelf ook bezig geweest en kwam op het volgende:
Code: 
Sub ExportX()
    Dim r As Long
    klant = [Info!G7]
    Offertenr = [Info!E7]
    path = ActiveWorkbook.path
    r = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    ActiveSheet.Range("$A$10:$AI$" & r).AutoFilter Field:=1, Criteria1:="X"
    r = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    Range(Replace("K11:K#,G11:G#,J11:J#,F11:F#,N11:N#", "#", r)).Copy
    Workbooks.Open Filename:="G:\DMR\CalculatieModel\Aanvraag Template V3.xlsm"
    Range("A2").Select
    ActiveSheet.Paste
    Cells.EntireColumn.AutoFit
    ActiveWorkbook.SaveAs Filename:=path & "\" & "Aanvraag" & klant & " " & Offertenr & ".xlsm"
End Sub
Alleen wanneer ik ActiveSheet.ShowAllData toevoeg na de copy actie. Dan werkt de macro niet meer en krijg ik deze fout melding:
1719839859419.png
 
Hoe kun je de volgorde van de kolommen wijzigen? Ik heb zoals je hierboven kunt zien de volgorde van de kolommen aangepast maar dit haalt niets uit.
 
Waar precies voeg je ActiveSheet.ShowAllData toe?
Volgorde kun je wijzigen door individuele kolommen te kopiëren, zelf nog even paden aanpassen:
Code: 
Sub ExportX()
    Dim r As Long
    klant = [Info!G7]
    Offertenr = [Info!E7]
    Path = ActiveWorkbook.Path
    r = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    ActiveSheet.Range("$A$10:$AI$" & r).AutoFilter Field:=1, Criteria1:="X"
    r = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    Range(Replace("K11:K#,G11:G#,J11:J#,F11:F#,N11:N#", "#", r)).Copy
    Workbooks.Open Filename:=Environ("userprofile") & "\Downloads\Aanvraag Template V2.xlsm"
    With ThisWorkbook.ActiveSheet
        .Range("K11:K" & r).Copy Range("A2")
        .Range("G11:G" & r).Copy Range("B2")
        .Range("F11:F" & r).Copy Range("C2")
        .Range("J11:J" & r).Copy Range("D2")
        .Range("N11:N" & r).Copy Range("E2")
    End With
    Cells.EntireColumn.AutoFit
    ActiveWorkbook.SaveAs Filename:=Environ("userprofile") & "\Downloads\output.xlsm"
End Sub
 
Code: 
Sub ExportX()
    Dim r As Long
    klant = [Info!G7]
    Offertenr = [Info!E7]
    Path = ActiveWorkbook.Path
    r = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    ActiveSheet.Range("$A$10:$AI$" & r).AutoFilter Field:=1, Criteria1:="X"
    r = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    Range(Replace("K11:K#,G11:G#,J11:J#,F11:F#,N11:N#", "#", r)).Copy
    ActiveSheet.ShowAllData
    Workbooks.Open Filename:=Environ("userprofile") & "\Downloads\Aanvraag Template V2.xlsm"
    With ThisWorkbook.ActiveSheet
        .Range("K11:K" & r).Copy Range("A2")
        .Range("G11:G" & r).Copy Range("B2")
        .Range("F11:F" & r).Copy Range("C2")
        .Range("J11:J" & r).Copy Range("D2")
        .Range("N11:N" & r).Copy Range("E2")
    End With
    Cells.EntireColumn.AutoFit
    ActiveWorkbook.SaveAs Filename:=Environ("userprofile") & "\Downloads\output.xlsm"
End Sub
 
Waarom het gebruik van 'Activesheet' ?
 
@HSV
Kan geen kwaad en is soms niet te vermijden, zo beter?

@jeroen7777
Beetje opgeschoond, zelf nog paden aanpassen:
Code: 
Sub ExportX()
    Dim r As Long
    klant = [Info!G7]
    Offertenr = [Info!E7]
    Path = ThisWorkbook.Path
    r = Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    Range("$A$10:$AI$" & r).AutoFilter Field:=1, Criteria1:="X"
    r = Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    Workbooks.Open Filename:=Environ("userprofile") & "\Downloads\Aanvraag Template V2.xlsm"
    With ThisWorkbook.ActiveSheet
        .Range("K11:K" & r).Copy Range("A2")
        .Range("G11:G" & r).Copy Range("B2")
        .Range("F11:F" & r).Copy Range("C2")
        .Range("J11:J" & r).Copy Range("D2")
        .Range("N11:N" & r).Copy Range("E2")
    End With
    Cells.EntireColumn.AutoFit
    ActiveWorkbook.SaveAs Filename:=Environ("userprofile") & "\Downloads\output.xlsm"
    ThisWorkbook.ActiveSheet.ShowAllData
End Sub
 
Mijn gedachte.
Code: 
Sub Exportx_hsv()
With ThisWorkbook.Sheets("prod.-stuklijst")
 With .Cells(10, 1).CurrentRegion
   .AutoFilter 1, "x"
     With .Parent.AutoFilter.Range.Offset(1)
      Set wb = Workbooks.Open(Environ("userprofile") & "\Downloads\Aanvraag Template V2.xlsm")
       Union(.Columns(11), .Columns(7), .Columns(6), .Columns(10), .Columns(14)).Copy wb.Sheets(1).Cells(1)
     wb.Sheets(1).Columns.AutoFit
     wb.Close -1
     End With
   .AutoFilter
 End With
End With
End Sub
 
@HSV
Zeker niet verkeerd!
Maar je overschrijft de kopregel, dus zou van cells(1) cells(2,1) maken. En ik vermoed dat het niet de bedoeling is dat het Template bestand wordt overschreven, dus toch misschien een wb.SaveAs, maar dat moet TS maar bepalen (en uitvoeren?).
 
Een paar kleine aanpassingen zoals omschreven door @AHulpje en je hebt een gedegen code.
 
Hallo,

Ik heb nog een vraag over de code die eerder is gebruikt.

Ik wil graag deze code aanpassen om de gegevens naar een ander document te exporteren.
Code: 
Sub ExportVWG()
    Dim r As Long
    klant = [Info!G7]
    Offertenr = [Info!E7]
    Path = ThisWorkbook.Path
    r = Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    Range("$A$10:$AI$" & r).AutoFilter Field:=1, Criteria1:="X"
    r = Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    Workbooks.Open Filename:="G:\Jetreports\Nav migratie\VERWANTE INKOOPPRIJS.xlsx"
    With ThisWorkbook.ActiveSheet
        .Range("F11:F" & r).Copy Range("A4")
        .Range("Y11:Y" & r).Copy Range("H4")
        .Range("O11:O" & r).Copy Range("G4")
        .Range("AP11:AP" & r).Copy Range("B4")
        .Range ("J4") =
    End With
    Cells.EntireColumn.AutoFit
    ActiveWorkbook.SaveAs Filename:=Path & "\" & " " & "Offertenr" & klant & " " & ".xlsx"
    ThisWorkbook.ActiveSheet.ShowAllData
End Sub

Vraag 1:
Wat ik graag wil ik dat kolom J in het geopende bestand gevuld wordt met de datum van vandaag in het volgende format : 2024-07. Hierachter moet nog een afkorting komen met de eerste letter van de voornaam van de huidige gebruiker en de eerst twee van de achternaam. In mijn geval zou dat "2024-07 JKO"zijn.
Is dit mogelijk? Om dit op elke regel te kopieren waar gegevens staan? Dus niet op de lege regels.

Vraag 2:
In de bovenste code wordt vanuit het huidge document de gegeven naar een ander document gekopieerd. Alleen staat in kolom AP een formule. Hiervan wil ik graag alleen de waarde kopieren.

Ik hoop dat jullie met weer zo goed kunnen helpen. Alvast bedankt!
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan