Gevens uit verschillende kollomen

[AHulpje]

Foutmelding?
Voorbeeld waarin het fout gaat (zonder lege rijen a.u.b.)?

 

[jeroen7777]

Het vreemde is dat ie het de ene keer wel doet en de andere keer doet ie helemaal niks. Ik kan hier niet zo een voorbeeld van geven. Ik dacht misschien dat je in de code iets ziet wat deze fout kan veroorzaken.

 

[Warme bakkertje]

Deze doet voor mij alles perfect.

 

[AHulpje]

Hoewel je voorbeelddata zich bij mij foutloos liet splitsen heb ik je code nog eens opgeschoond, bijgaand de nieuwe versie.

 

[jeroen7777]

Ik keeg vanmorgen eindelijk een foutmelding "onvoldoende geheugen".

Ik heb jou aangepaste versie ook geprobeerd maar deze verwerkt 1 regel en stopt dan.
Daarna heb 2 tabbladen 1 met de naam leveranciers die leeg is en daarna 1 met de naam van de eerste leverancier.

 

[Warme bakkertje]

Voor wie is welke commentaar?
Je moet enkel de SplitIntoMultiple.... code gebruiken want het aanpassen van de leveranciersnamen wordt daarin automatisch gestart.
Plaats anders nog eens het bestand waarin je de code gebruikt (zonder gevoelige info)

 

[AHulpje]

Plaats het document waarin het fout gaat eens hier.

 

[jeroen7777]

Ik heb stap voor stap geprobeerd en nu gaat ie fout wanneer de laatste leverancier verwerkt is. Hierna stopt i

Ik zal het document even aanpassen zodat ik het kan plaatsen

 

[jeroen7777]

Het werkt. Top!. Heel erg bedankt allemaal.
Er stonden weer lege regels in. Na het verwijderen van de lege regels werkt het.

 

[Warme bakkertje]

Hele kolommen gebruiken: slecht idee.

Regel per regel lezen en schrijven: slecht idee.

Function DeleteSpecialCharacters()
    With Columns("A:A")
        .Replace What:=" US$", Replacement:=""
        .Replace What:=".", Replacement:=""
        .Replace What:=",", Replacement:=""
    End With
    r = 2
    Do While Cells(r, 1) <> vbNullString
        Cells(r, 1) = Left(Cells(r, 1), 31)
        r = r + 1
    Loop
End Function

Beter en veeeel sneller bij grote datasets.

Sub DeleteSpecCharacters()
'
' DeleteSpecialCharacters Macro
'
    a = Range("A2", Range("A" & Rows.Count).End(xlUp))
    For i = 1 To UBound(a)
        If a(i, 1) <> vbNullString Then
            a(i, 1) = Replace(Replace(Replace(a(i, 1), " US$", ""), ".", ""), ",", "")
            a(i, 1) = Left(a(i, 1), 31)
        End If
    Next
    Range("A2").Resize(UBound(a)) = a

End Sub

 

[jeroen7777]

Hallo,

Nog een vraagje: Ik heb onderstaande code om een aantal sheet te kopieren:

Sub ExportSales()
'
' Macro3 Macro
'
Dim FilePath As String
    Dim wsh As Worksheet
    FilePath = Application.ActiveWorkbook.Path
    OfferteNummer = ThisWorkbook.Sheets("RFQ").Range("B4")
    ArtikelNummer = ThisWorkbook.Sheets("Quote").Range("B6")
    myFile = FilePath & "\" & "Open Costing" & " " & OfferteNummer & " " & ArtikelNummer & " " & Format(Date, "DD-MMMM-YYYY") & ".xlsx"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim MyInput As String
    Sheets(Array("RFQ", "Quote", "BOM PCBA", "BOM Box Build")).Copy
    Application.ActiveWorkbook.SaveAs Filename:=myFile
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.Delete
    Application.ActiveWorkbook.Close False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Alleen worden de formules meegekopieerd wat niet wenselijk is. Ik wil graag alleen de waardes kopieren.
Nu heb ik gevonden dat het met de volgende code zou kunnen alleen weet ik niet waar ik deze moet plaatsten.

ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value

Ik hoop dat jullie mij weer kunnen helpen.

Alvast bedankt!

 

[AHulpje]

Plaats dit

    For Each sht In ActiveWorkbook.Sheets
        sht.UsedRange.Value = sht.UsedRange.Value
    Next

direct onder

Sheets(Array("RFQ", "Quote", "BOM PCBA", "BOM Box Build")).Copy

 

[jeroen7777]

Heel erg bedankt dit werkt. Top!

 

[jeroen7777]

Aangezien jullie mij hier de vorige keren zo goed hebben geholpen heb ik nog een vraag. Kan in onderstaande code ook gefilterd worden op een bepaalde celkleur?

Function SplitSheetIntoMultipleSheetsBasedOnColumn()
    Dim objDatasheet As Worksheet
    Dim nLastRow     As Long
    Dim objSheet     As Worksheet
   
    Set objDatasheet = ActiveSheet
    nLastRow = objDatasheet.Range("A" & objDatasheet.Rows.Count).End(xlUp).Row
    leveranciers = Application.WorksheetFunction.Unique(Range("A2:A" & nLastRow))
 
    For Each leverancier In leveranciers
        Set objSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        objSheet.Name = leverancier
        With objDatasheet
            .AutoFilterMode = False
            With .UsedRange
                objDatasheet.UsedRange.AutoFilter Field:=1, Criteria1:=leverancier
                .SpecialCells(xlCellTypeVisible).Copy Sheets(leverancier).Range("A1")
                Range("A1").Copy
                Application.CutCopyMode = False
            End With
        End With
        objSheet.Columns("A:F").AutoFit
    Next
    objDatasheet.AutoFilterMode = False
End Function

Ik heb een ander document waarin ik hetzelfde wil doen als eerder met de leveranciers. Ik wil graag de regels exporteren die na voorwaardelijke opmaak wit zijn gebleven, dus geen kleur hebben gekregen en opslaan in een nieuw bestand. De cel bevind zich in kolom K,
Ik heb het idee dat ik de volgende regel moet aanpassen alleen weet ik niet hoe:

leveranciers = Application.WorksheetFunction.Unique(Range("A2:A" & nLastRow))

Ik wilde Unique vervangen door Colorindex maar dit werkt niet.
Ook zou ik dat graag alleen kolommen E,F,J en M menemen ( als dit mogelijk is)
Kunnen jullie mij nogmaals helpen?
Alvast bedankt!

 

[AHulpje]

Dus eigenlijk wil je van alle rijen uit een bepaald werkblad waarvoor kolom K niet voldoet aan je voorwaardelijke opmaakcriterium de kolommen E, F, J en M exporteren?
Plaats dat werkblad eens hier.

 

[jeroen7777]

Het mag ook in plaats van op cel kleur, op basis van een nieuwe kolom waar we een kruis of iets dergelijks in kunnen zetten

 

[AHulpje]

Gefilterd op "geen opvulling" in kolom K:

 

[jeroen7777]

Top dankjewel! Dit werkt.
En wanneer ik dit zou willen maar dan op basis van een extra kolom aan het begin (voor de huidige kolom A) met een x als waarde. Wat moet er dan aangepast worden en waarnaar? En wanneer ik de gegevens naar een bestaand bestand zou willen exporteren?

 

[AHulpje]

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
    Sheets.Add After:=ActiveSheet
    Range("A1").Select
    ActiveSheet.Paste
    Cells.EntireColumn.AutoFit
End Sub

 

[jeroen7777]

Deze werkt helaas niet, ik krijg een leeg blad met alleen de exportknop.

Wanneer ik kijk naar het filter dan staat die in kolom B ipv kolom A