Üres cella megjelölése és érték megadása másik cellába

Üres cella megjelölése és érték megadása másik cellába
2022-01-26T12:37:55+01:00
2022-01-28T09:01:32+01:00
2022-10-15T21:20:39+02:00
Pilu88
Sziasztok,
Ellenőrizni szeretném , hogy minden adat ki van-e töltve. Három oszlopot kell figyelembe venni az "I, J, K". Minden oszlophoz tartozik egy kulcsszó.  Abban az esetben ha a cellája üres, akkor az üres cellát meg kell jelölni pirossal, és az L oszlopba be kell írni az üres cella oszlopához tartozó kulcsszót. És az M oszlopba be kell írni, hogy 400. 
Pl         I            J          K        L                            M    
     1   qqqq                  rrrr     TKP                       400  
     2                dddd              N11,VRN5             400    
     3   SSSS     dddd               VRN5                    400    
    4                                        N11,TKP,VRN5     400

kulcsszavak:    I = N11,  J = TKP, K = VRN5,   A cellák megjelölése nem volt nehéz, viszont a az értékek kiírására valami egyszerűbb módszert tud valaki, hogy ne kelljen az összes if variációt leírni?



Sub ecell() Dim i As Long Dim c As Long Dim myRange As Range Dim myCell As Range Set myRange = Range("I2:K102") For Each myCell In myRange ' c = c + 1 If IsEmpty(myCell) Then myCell.Interior.ColorIndex = 3 i = i + 1 End If Next myCell End Sub
Mutasd a teljes hozzászólást!
Szia!
Ezt a részt 

mycell.Resize(1, 3).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3 If u > 0 Then mycell.Offset(0, 3).Value = k(u): mycell.Offset(0, 4).Value = 400
légy szíves módosítsd így:

If u > 0 Then mycell.Offset(0, 3).Value = k(u): mycell.Offset(0, 4).Value = 400 mycell.Resize(1, 3).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3 End If
Üdv.
Mutasd a teljes hozzászólást!

  • Szia!
    Nézd meg légy szíves ezt a makrót:

    Sub KITOLTO() Dim mycell As Range, k(7) As String, u As Integer k(1) = "N11": k(2) = "TKP": k(4) = "VNR5": k(5) = k(1) & "," & k(2): k(6) = k(2) & "," & k(4): k(7) = k(5) & "," & k(4) For Each mycell In Range("I2:I102").Cells u = (mycell.Value = "") * -1 + (mycell.Offset(0, 1).Value = "") * -2 + (mycell.Offset(0, 2).Value = "") * -4 mycell.Resize(1, 3).Interior.ColorIndex = -4142 mycell.Resize(1, 3).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3 If u > 0 Then mycell.Offset(0, 3).Value = k(u): mycell.Offset(0, 4).Value = 400 Next End Sub
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia,

    szépen végigmegy megtalálja az üres cellákat , viszont amikor elfogy az üres cella akkor kiakad ennél hogy nem talál cellát

    mycell.Resize(1, 3).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3
    Mutasd a teljes hozzászólást!
  • Szia!
    Ezt a részt 

    mycell.Resize(1, 3).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3 If u > 0 Then mycell.Offset(0, 3).Value = k(u): mycell.Offset(0, 4).Value = 400
    légy szíves módosítsd így:

    If u > 0 Then mycell.Offset(0, 3).Value = k(u): mycell.Offset(0, 4).Value = 400 mycell.Resize(1, 3).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3 End If
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia!
    Kicsit még átbogarásztam a makrót és találtam benne hibát. Itt a javított, ami remélhetőleg már pontos lesz. Ezt egyes cellák kitöltése után ismételten lefuttatva módosítja az új helyzetnek megfelelően a cellák háttérszínét és az L - M oszlop értékeit. 

    Sub KITOLTO() Dim mycell As Range, k(7) As String, u As Integer k(1) = "N11": k(2) = "TKP": k(3) = k(1) & "," & k(2): k(4) = "VNR5": k(5) = k(1) & "," & k(4): k(6) = k(2) & "," & k(4): k(7) = k(3) & "," & k(4) For Each mycell In Range("I2:I102").Cells u = (mycell.Value = "") * -1 + (mycell.Offset(0, 1).Value = "") * -2 + (mycell.Offset(0, 2).Value = "") * -4 mycell.Resize(1, 3).Interior.ColorIndex = -4142: mycell.Offset(0, 3).Value = "": mycell.Offset(0, 4).Value = "" If u > 0 Then mycell.Offset(0, 3).Value = k(u): mycell.Offset(0, 4).Value = 400 mycell.Resize(1, 3).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3 End If Next End Sub
    Üdv.
    Mutasd a teljes hozzászólást!
  • Köszönöm szépen a segítséget.
    Mutasd a teljes hozzászólást!
Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd