Filter om alleen tekst en lege cellen te verwijderen

Status
Niet open voor verdere reacties.
globe

globe

Verenigingslid
Lid geworden
18 mrt 2001
Berichten
3.616
Was ik weer ;)

In het vervolg op mijn vorige vragen loop ik nog tegen 1 kleinigheidje aan.


Ik heb van het internet de volgende code geplukt die uit kolom B (2) alle lege waardes verwijdert, dit werkt als een trein

Code: 
Columns(2).SpecialCells(4).EntireRow.Delete

Nu staan er in de resultaten ook tekst die ook verwijdert moeten worden zodat ik alleen de getallen overhoud, hoe ga ik dat aanpakken?

Dank alvast.
 
Probeer deze eens

Code: 
Sub jec()
 Application.ScreenUpdating = False
 With Range("B1", Range("B" & Rows.Count).End(xlUp))
   .Value = Evaluate("iferror(1/(1/(" & .Address & "+0)),""#N/A"")")
    On Error Resume Next
   .SpecialCells(2, 16).EntireRow.Delete
 End With
End Sub
 
helaas.... Deze werkt niet. Ik vermoed dat het in het feit zit dat de werklbladen als tekst zijn opgemaakt.

Dit is de gehele code, de bladen worden als tekst aangemaakt, anders gaan de getalnotaties stuk.

Code: 
'kopieer data uit tabbladen naar Order 1 tabblad
   


 Dim ar, sh As Variant, i As Long, dict As Object
 
 Set dict = CreateObject("scripting.dictionary")
 For Each sh In wbkCurrent.Sheets
 
       
    If sh.Index > 1 Then
      ar = sh.Range("A1:Q" & sh.Range("F" & Rows.Count).End(xlUp).Row)
      
      
      
      For i = 2 To UBound(ar)
          If Len(ar(i, 6)) Then dict(dict.Count) = Array(ar(i, 6), ar(i, 15), ar(i, 16), ar(i, 17))
      Next
    End If
 Next
 With Sheets.Add(, Sheets(Sheets.Count))
    .Name = "Order1"
    .Cells.NumberFormat = "@"
    .Cells(1, 1).Resize(dict.Count, 4) = Application.Index(dict.items, 0, 0)
 End With
 
 'voeg tabbladen Orde 2 en order 3 toe en kopieer data
 
 Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Order2"
    Sheets("Order2").Select
    Cells.Select
    Selection.NumberFormat = "@"

Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Order3"
    Sheets("Order3").Select
    Cells.Select
    Selection.NumberFormat = "@"
    
    Sheets("Order1").Select
    Rows("1").EntireRow.Delete

    Columns("A:D").Select
    Selection.Copy
    Sheets("Order2").Select
    Range("a1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("B").EntireColumn.Delete
    Columns("C").EntireColumn.Delete
 
    Application.ScreenUpdating = False
 With Range("B1", Range("B" & Rows.Count).End(xlUp))
   .Value = Evaluate("iferror(1/(1/(" & .Address & "+0)),""#N/A"")")
    On Error Resume Next
   .SpecialCells(2, 16).EntireRow.Delete
   
   End With

dit is de output van de CSV:

Code: 
768686139048;1
768686333569;#N/A
768686333576;#N/A
768686138911;#N/A
768686138928;#N/A
768686139031;1
768686139048;1
768686424625;#N/A
768686424632;#N/A

Zoals je ziet zijn de tekst regels niet vervangen
 
Laatst bewerkt:
Kan je anders een representatief voorbeeldje plaatsen?
 
Zekers, fijn dat je de moeite neemt om mee te kijken.

Dit is een voorbeeld van een orderform wat ik van klanten krijg.

De geschreven code schoont dit op naar een importeerbare CSV, in dit geval 3.

dit is de code die ik daar voor gemaakt heb, met hulp van onder ander jouw code.

Voor jullie experts tenenkrommende code :d

Code: 
Sub Maak_import_csv()


'selecteer huidige excel als actieve file

Dim wbkCurrent As Workbook

Set wbkCurrent = ActiveWorkbook

'tel aantal tabbladen


aantaltabs = Application.Sheets.Count

'selecteer alle tabbladen behalve de eerste, zet kolom F om naar tekst met Tekst naar Kolommen, check of klom F data bevat

    For ordersheet = 1 To aantaltabs
    
    Worksheets(ordersheet).Select
    
        
  
        If WorksheetFunction.CountA(Range("F:F")) = 0 Then
        
        Worksheets(ordersheet + 1).Select
        
        Else
        
        Worksheets(ordersheet).Select
   
        Columns("F:F").Select
        Selection.TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 2), TrailingMinusNumbers:=True
      End If
           
   Next ordersheet
   
'kopieer data uit tabbladen naar Order 1 tabblad
   


 Dim ar, sh As Variant, i As Long, dict As Object
 
 Set dict = CreateObject("scripting.dictionary")
 For Each sh In wbkCurrent.Sheets
 
       
    If sh.Index > 1 Then
      ar = sh.Range("A1:Q" & sh.Range("F" & Rows.Count).End(xlUp).Row)
      
      
      
      For i = 2 To UBound(ar)
          If Len(ar(i, 6)) Then dict(dict.Count) = Array(ar(i, 6), ar(i, 15), ar(i, 16), ar(i, 17))
      Next
    End If
 Next
 With Sheets.Add(, Sheets(Sheets.Count))
    .Name = "Order1"
    .Cells.NumberFormat = "@"
    .Cells(1, 1).Resize(dict.Count, 4) = Application.Index(dict.items, 0, 0)
 End With
 
 'voeg tabbladen Orde 2 en order 3 toe en kopieer data
 
 Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Order2"
    Sheets("Order2").Select
    Cells.Select
    Selection.NumberFormat = "@"

Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Order3"
    Sheets("Order3").Select
    Cells.Select
    Selection.NumberFormat = "@"
    
    Sheets("Order1").Select
    Rows("1").EntireRow.Delete

    Columns("A:D").Select
    Selection.Copy
    Sheets("Order2").Select
    Range("a1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("B").EntireColumn.Delete
    Columns("C").EntireColumn.Delete
 
    Columns(2).SpecialCells(4).EntireRow.Delete
    
    Sheets("Order1").Select
    

    Columns("A:D").Select
    Selection.Copy
    
    
    Sheets("order3").Select
    Range("a1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Columns("B").EntireColumn.Delete
    Columns("B").EntireColumn.Delete
    
    Columns(2).SpecialCells(4).EntireRow.Delete
    
    Sheets("Order1").Select
    Columns("C:D").EntireColumn.Delete
    
    Columns(2).SpecialCells(4).EntireRow.Delete
   
    
    Application.ScreenUpdating = False

'geef hieronder aan uit welke cel de klant en orderomschrijving moeten worden gehaald, uit tabblad 1!

    Klant = Worksheets(1).Range("D5")
    Orderdesc = Worksheets(1).Range("D3")
    Folder = GetFolder 'kies of folder gekozen moet worden
    'Folder = "F:....." 'geef hier evt standaard locatie aan
    
    

    For Each ws In Sheets(Array("Order1", "Order2", "Order3"))
       ws.Copy
       With ActiveWorkbook
       
      No_Of_Rows = ActiveSheet.UsedRange.Rows.Count
      
      

     

          .SaveAs Folder & "\" & Klant & "_" & Orderdesc & "_" & ActiveSheet.Name & "_" & Format(Now(), "DD-MMM-YYYY") & "_" & No_Of_Rows & "_regels.csv", xlCSV, Local:=True
          .Close False
          
        
                    
       End With
    Next ws
    

'verwijder de tijdelijk aangemaakte hulpkolommen

   Application.DisplayAlerts = False

    Sheets(Array("Order1", "Order2", "order3")).Select
    Sheets("order3").Activate
    ActiveWindow.SelectedSheets.Delete
    
    
     Application.DisplayAlerts = True

    
  



End Sub

    Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Selecteer een Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
    Set fldr = Nothing
End Function
 

Bijlagen

Laatst bewerkt:
En wat moet er nu precies gebeuren? Ik zie nergens getallen in kolom B.
 
1000 maal excuses, ik post de verkeerde excel zie ik nu. Dat was een reeds met de hand opgeschoonde versie.

dit is een praktijkvoorbeeld, hier staan tussen artikelen die besteld kunnen worden nog tekstregels. Deze kunnen variëren, de beste oplossing is daarom ze uit de uiteindelijke CSV files/tabbladen te filteren en te verwijderen.
 

Bijlagen

Ik zie het nog steeds niet. Als je aan de hand van je voorbeeld precies vertelt wat er met welke kolom moet gebeuren, komen we vast ergens.
Kolom B bevat nog geen getallen.
 
JVeer zei:
Ik zie het nog steeds niet. Als je aan de hand van je voorbeeld precies vertelt wat er met welke kolom moet gebeuren, komen we vast ergens.
Kolom B bevat nog geen getallen.
Klik om te vergroten...

Aha, ik begrijp je verwarring. Het voorbeeld bestand gaat om kolom F, O, P en Q.

Als je de macro draait zullen deze 4 kolommen van ieder tabblad gekopieerd worden naar 3 nieuw aangemaakte tabs: Order1, order2 en order3.

Deze tabs bestaan uit 2 rijen. Kolom A en B. Deze 3 sheets worden naar een CSV geëxporteerd, zie hieronder de inhoud van zo'n csv.

Code: 
768686425196;1
768686425233;1
768686425318;1
EAN;Order1
768686732690;1
768686732706;1
768686732713;1

Zoals je ziet staat er tussen de codes ineens een regel tekst, die moet vóór het naar een CSV exporteren verwijderd worden.


Ik hoop dat het zo wat duidelijk is.
 
Als je dit deel aanpast naar het volgende: (zie dat EAN wordt weggelaten)

Code: 
 Dim ar, sh As Variant, i As Long, dict As Object
 
 Set dict = CreateObject("scripting.dictionary")
 For Each sh In wbkCurrent.Sheets
    If sh.Index > 1 Then
      ar = sh.Range("A1:Q" & sh.Range("F" & Rows.Count).End(xlUp).Row)
      For i = 2 To UBound(ar)
          If Len(ar(i, 6)) And instr(ar(i, 6), "EAN") = 0 Then dict(dict.Count) = Array(ar(i, 6), ar(i, 15), ar(i, 16), ar(i, 17))
      Next
    End If
 Next
 With Sheets.Add(, Sheets(Sheets.Count))
    .Name = "Order1"
    .Cells.NumberFormat = "@"
    .Cells(1, 1).Resize(dict.Count, 4) = Application.Index(dict.items, 0, 0)
 End With
 
Laatst bewerkt:
Dank, dat kan in dit geval een oplossing zijn. Nu komen er echter soms ook andere teksten voor. Kan ik ook iets met een Wildcard doen * ?
Het woord EAN zal doorgaans wel in de cel staan maar kan soms aangevuld zijn met meer tekst. eigenlijk zou de uit te sluiten waarde "*EAN*" moeten zijn.
 
Dat kan ook, heb de vorige post aangepast
 
Dat kan handiger:
tekst in kolom F verwijderen:
Code: 
Sub M_snb()
   sheet1.columns(6).specialcells(2,2).entirerow.delete
End Sub
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan