πινακας Excel

[papazaf]

παιδια στην φωτο ειναι ενας πινακας του excel,

προσπαθω να φτιαξω μια μακρο που να σβηνει τα κελια εκτος απο αυτα που εχουν νουμερο μεσα τους, το θεμα ειναι οτι σε αυτα που εχουν νουμερο πρεπει να μενει και η ημερομηνια στην κολωνα, στα αδεια να σβηνεται,

εχει κανεις κανενα tip?

[papazaf]

παιδια στην φωτο ειναι ενας πινακας του excel,

προσπαθω να φτιαξω μια μακρο που να σβηνει τα κελια εκτος απο αυτα που εχουν νουμερο μεσα τους, το θεμα ειναι οτι σε αυτα που εχουν νουμερο πρεπει να μενει και η ημερομηνια στην κολωνα, στα αδεια να σβηνεται,

εχει κανεις κανενα tip?

[speculator]

Ριξε μια ματια και στο http://www.carputermania.gr/ και θα παρεις περισσοτερη βοηθεια

[speculator]

Ριξε μια ματια και στο http://www.carputermania.gr/ και θα παρεις περισσοτερη βοηθεια

[papazaf]

φιλε μου μαλλον το εβαλες σε λαθος ποστ

[papazaf]

φιλε μου μαλλον το εβαλες σε λαθος ποστ

[UserXP]

Βάλε τον παρακάτω κώδικα σε μια λειτουργική μονάδα

 

>
Sub ParseTableForBlankCells()
Dim r As Range, i As Long, j As Long
Dim aCell As Range, CellWithDate As Range
Dim countNums As Long

Set r = Selection

For i = 1 To r.Columns.Count
   countNums = 0
   For j = 1 To r.Rows.Count
       Set aCell = r.Cells(j, i)
       If IsDate(aCell) Then
           If Not CellWithDate Is Nothing Then
               If countNums = 0 Then CellWithDate.Value = ""
           End If
           Set CellWithDate = aCell
           countNums = 0
       Else
           If IsNumeric(aCell) And (Not IsEmpty(aCell)) Then
               countNums = countNums + 1
           Else
               aCell.Value = ""
           End If
       End If
   Next j
   If Not CellWithDate Is Nothing Then
       If countNums = 0 Then CellWithDate.Value = ""
       Set CellWithDate = Nothing
   End If
Next i

End Sub

 

Επέλεξε τον πίνακα και τρέξε την παραπάνω μάκρο.

[papazaf]

φιλε μου φαινεται οτι δουλευει , σε ευχαριστω πολυ

[papazaf]

φιλε userXP μηπωσ τωρα ξερεις πως μπορω να σβησω τα κενα κελια, αλλα οχι αυτα που ειναι κατω απο τις ημερομηνιες, δηλαδη κατι σαν shift left

να μεινει η ημερομηνια σαν header το νουμερο κατω απο την ημερομηνια στην γραμμη που ειναι, αλλα να ερθουν ολα δεξια???

ζηταω πολλα?

σε ευχαριστω

[UserXP]

Δηλαδή εννοείς αν στον πίνακα υπάρχουν κενές στήλες (ανά ημερομηνία) αυτές να διαγραφούν και να μείνουν μόνο οι ημερομηνίες και οι τιμές συγκεντρωμένες σε ένα μέρος;

[UserXP]

Αν τέλος πάντων θέλεις αυτό που είπα παραπάνω, αντικατέστησε τον παραπάνω κώδικα με αυτόν

 

>
Sub ParseTableForBlankCells()
Dim r As Range, i As Long, j As Long
Dim aCell As Range, CellWithDate As Range
Dim countNums As Long, RangeToDelete As Range, txtRangeToDelete As String
Dim a

Set r = Selection

For i = 1 To r.Columns.Count
   countNums = 0
   For j = 1 To r.Rows.Count
       Set aCell = r.Cells(j, i)
       If IsDate(aCell) Then
           If Not CellWithDate Is Nothing Then
               If countNums = 0 Then
                   CellWithDate.Value = ""
                   Set RangeToDelete = Range(CellWithDate, r.Cells(j - 1, i))
                   txtRangeToDelete = txtRangeToDelete & RangeToDelete.Address & ";"
               End If
           End If
           Set CellWithDate = aCell
           countNums = 0
       Else
           If IsNumeric(aCell) And (Not IsEmpty(aCell)) Then
               countNums = countNums + 1
           Else
               aCell.Value = ""
           End If
       End If
   Next j
   If Not CellWithDate Is Nothing Then
       If countNums = 0 Then
           CellWithDate.Value = ""
           Set RangeToDelete = Range(CellWithDate, r.Cells(j - 1, i))
           txtRangeToDelete = txtRangeToDelete & RangeToDelete.Address & ";"
       End If
       Set CellWithDate = Nothing
   End If
Next i

If txtRangeToDelete <> "" Then
   txtRangeToDelete = Left(txtRangeToDelete, Len(txtRangeToDelete) - 1)
   a = Split(txtRangeToDelete, ";")
   For i = UBound(a) To LBound(a) Step -1
       Range(a(i)).Delete xlShiftToLeft
   Next i
End If

End Sub

[papazaf]

ναι, θα ηθελα τα κενα αναμεσα στην ημερομηνια και το νουμερο απο κατω να παραμεινει ομως(σαν κολωνα δηλαδη)....γινεται με καποιον τροπο , γιατι εκατσα να τα σβησω με το χερι και δεν βγαινει , ειναι περιπου 4000 γραμμες

[UserXP]

Δοκίμασε τον παραπάνω κώδικα, αλλά πρέπει να τον δοκιμάσεις στον αρχικό πίνακα για να δουλέψει.

[papazaf]

φαινεται οτι δουλευει,

αν τα εχει κανει σωστα θα σου αναψω λαμπαδα

σε ευχαριστω πολυ