[es] - vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele

gogi100
Goran Ljubic

Član broj: 40722
Poruke: 1064
*.static.isp.telekom.rs.

+3 Profil

vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele

^{17.08.2018. u 09:21 - pre 68 meseci}

Imam excel sa sheet, zakacen u poruci. Kreirao sam makro koji kreira jos jedan sheet Karnet
koji u prvoj koloni sadrzi zaposlene, a u prvom redu polja su popunjena datumima iz tekuceg meseca. imam kod makroa

Code:
Sub Karnet()
Dim wsowssvr As Worksheet, wsKarnet As Worksheet
Dim intDaysInMonth As Integer
Dim i As Integer
Dim rsharepoint As Integer 'kolona sharepoint
Dim rkarnet As Integer 'red karnet
Dim kkarnet As Integer  ' kolona karnet
Dim zkkarnet As Integer 'zadnja kolona karnet -broj
Dim zrsharepoint As Integer 'zadnja kolona sharepoint
Dim zrkarnet As Integer 'zadnji red karnet -broj

'Korak 1:  dodaje sheet, daje mu ime
    Sheets.Add.Name = "Karnet"

'Korak 2: kopira kolonu zaposleni bez duplikata u Karnet sheet
    Set wsowssvr = Sheets("owssvr")
    Set wsKarnet = Sheets("Karnet")
    wsowssvr.Range("C:C").Copy wsKarnet.Range("A1")
    wsKarnet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

'Korak 3: kreira kolone, cije zaglavlje su datumi tekuceg meseca
    intDaysInMonth = Day(DateSerial(Year(Now()), Month(Now()) + 1, 0))
    wsKarnet.Cells(1, 2).Resize(intDaysInMonth, 1).ClearContents
    For i = 1 To intDaysInMonth
        wsKarnet.Cells(1, 2).Offset(0, i - 1) = DateSerial(Year(Now()), Month(Now()), i)
    Next i


'Korak 4: popunjavanje karneta
    zkkarnet = wsKarnet.UsedRange.Rows(1).Columns.Count
    zrkarnet = wsKarnet.UsedRange.Columns(1).Rows.Count
    zrsharepoint = wsowssvr.UsedRange.Columns(1).Rows.Count


    For rkarnet = 2 To zrkarnet
    For kkarnet = 2 To zkkarnet
     For rsharepoint = 2 To zrsharepoint
    If wsKarnet.Cells(rkarnet, 1).Value = wsowssvr.Cells(rsharepoint, 3).Value And wsKarnet.Cells(1, kkarnet).Value = wsowssvr.Cells(rsharepoint, 1).Value And wsowssvr.Cells(rsharepoint, 5).Value = True Then
    wsKarnet.Cells(rkarnet, kkarnet).Value = "+"
    Else
   wsKarnet.Cells(rkarnet, kkarnet).Value = "-"
    End If

    Next rsharepoint
    Next kkarnet
    Next rkarnet






End Sub

Dakle treba mi makro koji ce porediti kolone Zaposleni u oba sheet-a, datume iz prvog reda sheet-a Karnet sa sa kolonom startni datum i ako je u koloni Prisustvo 'True' u odgovarajucem polju za zaposlenog i datuma da upise simbol +, ostalo -.
Uspeo sam da upisem u polja - ali mi ne radi provera preko if petlje. Mozete li mi pomoci. Hvala

Prikačeni fajlovi

Book2.xlsm - 25.54k

Odgovor na temu

gogi100
Goran Ljubic

Član broj: 40722
Poruke: 1064
*.static.isp.telekom.rs.

+3 Profil

Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele

^{17.08.2018. u 10:22 - pre 68 meseci}

razreseno sledecim kodom

Code:
Sub Karnet()
Dim wsowssvr As Worksheet, wsKarnet As Worksheet
Dim intDaysInMonth As Integer
Dim i As Integer
Dim rsharepoint As Integer 'kolona sharepoint
Dim rkarnet As Integer 'red karnet
Dim kkarnet As Integer  ' kolona karnet
Dim zkkarnet As Integer 'zadnja kolona karnet -broj
Dim zrsharepoint As Integer 'zadnja kolona sharepoint
Dim zrkarnet As Integer 'zadnji red karnet -broj

'Korak 1:  dodaje sheet, daje mu ime
    Sheets.Add.Name = "Karnet"

'Korak 2: kopira kolonu zaposleni bez duplikata u Karnet sheet
    Set wsowssvr = Sheets("owssvr")
    Set wsKarnet = Sheets("Karnet")
    wsowssvr.Range("C:C").Copy wsKarnet.Range("A1")
    wsKarnet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

'Korak 3: kreira kolone, cije zaglavlje su datumi tekuceg meseca
    intDaysInMonth = Day(DateSerial(Year(Now()), Month(Now()) + 1, 0))
    wsKarnet.Cells(1, 2).Resize(intDaysInMonth, 1).ClearContents
    For i = 1 To intDaysInMonth
        wsKarnet.Cells(1, 2).Offset(0, i - 1) = DateSerial(Year(Now()), Month(Now()), i)
    Next i


'Korak 4: popunjavanje karneta
    zkkarnet = wsKarnet.UsedRange.Rows(1).Columns.Count
    zrkarnet = wsKarnet.UsedRange.Columns(1).Rows.Count
    zrsharepoint = wsowssvr.UsedRange.Columns(1).Rows.Count


    For rkarnet = 2 To zrkarnet
    For kkarnet = 2 To zkkarnet
     For rsharepoint = 2 To zrsharepoint
    If wsKarnet.Cells(rkarnet, 1).Value = wsowssvr.Cells(rsharepoint, 3).Value And wsKarnet.Cells(1, kkarnet).Value = wsowssvr.Cells(rsharepoint, 1).Value And wsowssvr.Cells(rsharepoint, 5).Value = True Then
    wsKarnet.Cells(rkarnet, kkarnet).Value = "+"
    ElseIf wsKarnet.Cells(rkarnet, 1).Value = wsowssvr.Cells(rsharepoint, 3).Value And wsKarnet.Cells(1, kkarnet).Value = wsowssvr.Cells(rsharepoint, 1).Value And wsowssvr.Cells(rsharepoint, 5).Value = False Then
    wsKarnet.Cells(rkarnet, kkarnet).Value = "-"
    End If

    Next rsharepoint
    Next kkarnet
    Next rkarnet






End Sub

Odgovor na temu

bokinet

Član broj: 29844
Poruke: 574

+50 Profil

Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele

^{17.08.2018. u 10:27 - pre 68 meseci}

Mnogo ste ga ukomplikovali :)

Evo brzinskog cisto da imate pa se dalje peglajte i cistite kod.

Code:

Sub Karnet()
Dim wsOWSSvr As Worksheet, wsKarnet As Worksheet
Dim intDaysInMonth As Integer
Dim i As Integer
Dim rsharepoint As Integer 'kolona sharepoint
Dim rkarnet As Integer 'red karnet
Dim kkarnet As Integer  ' kolona karnet
Dim zkkarnet As Integer 'zadnja kolona karnet -broj
Dim zrsharepoint As Integer 'zadnja kolona sharepoint
Dim zrkarnet As Integer 'zadnji red karnet -broj

'Korak 1:  dodaje sheet, daje mu ime
    'Sheets.Add.Name = "Karnet"

'Korak 2: kopira kolonu zaposleni bez duplikata u Karnet sheet
    'Set wsOWSSvr = Sheets("owssvr")
    'Set wsKarnet = Sheets("Karnet")

    Set wsKarnet = ActiveWorkbook.Sheets("Karnet")
    Set wsOWSSvr = ActiveWorkbook.Sheets("owssvr")

    wsOWSSvr.Range("C:C").Copy wsKarnet.Range("A1")
    wsKarnet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

'Korak 3: kreira kolone, cije zaglavlje su datumi tekuceg meseca
    intDaysInMonth = Day(DateSerial(Year(Now()), Month(Now()) + 1, 0))
    wsKarnet.Cells(1, 2).Resize(intDaysInMonth, 1).ClearContents
    For i = 1 To intDaysInMonth
        wsKarnet.Cells(1, 2).Offset(0, i - 1) = DateSerial(Year(Now()), Month(Now()), i)
    Next i


'Korak 4: popunjavanje karneta
    zkkarnet = wsKarnet.UsedRange.Rows(1).Columns.Count
    zrkarnet = wsKarnet.UsedRange.Columns(1).Rows.Count
    zrsharepoint = wsOWSSvr.UsedRange.Columns(1).Rows.Count

    ' --------------------------------------------------------
    ' Code update goes from here
    ' ---> Goes from here <---
    ' --------------------------------------------------------

    Dim curDatumOd As String
    Dim curDatumDo As String
    Dim curPrisutan As Boolean
    Dim curValue As String
    Dim curDay As Integer
    Dim curZap As Long
    Dim iTotal As Long
    Dim mZaposleni As Collection
    Dim totalZap As Long

    ' Ukupno zapisa
    iTotal = wsKarnet.UsedRange.Columns(1).Rows.Count

    ' Ukupno zaposlenih
    totalZap = wsOWSSvr.UsedRange.Columns(1).Rows.Count

    ' Create new instance of object
    Set mZaposleni = New Collection

    ' Napravi listu zaposlenih koji se nalaze u tabeli kao kolekciju gde je vrednost ustvari Row u Worksheet-u
    For i = 2 To totalZap

        ' Doddaj zapis u kolekciju
        mZaposleni.Add i, wsOWSSvr.Cells(i, 3)

    Next

    For i = 2 To iTotal

        ' Default value to set
        curValue = "-"

        ' Datum Od
        curDatumOd = wsOWSSvr.Cells(i, 1)

        ' Datum Do
        curDatumDo = wsOWSSvr.Cells(i, 2)

        ' Pristan True/False
        curPrisutan = CBool("" & wsOWSSvr.Cells(i, 5))

        ' If Prisutan is True then update current value which will be set in other worksheet
        If curPrisutan = True Then curValue = "+"

        ' Trenutni dan - na osnovu dana kreira se kolona
        curDay = CInt(Format(curDatumOd, "d")) + 1

        ' Uzima se lokacija zaposlenog u tabeli
        curZap = mZaposleni(wsOWSSvr.Cells(i, 3))

        ' Dodeljuje vrednost +/-
        wsKarnet.Cells(curZap, curDay) = curValue

        Debug.Print curZap, curDatumOd, curDatumDo, curPrisutan, curDay, curValue

    Next

    ' Free memory resource
    Set mZaposleni = Nothing

End Sub

Odgovor na temu

bokinet

Član broj: 29844
Poruke: 574

+50 Profil

Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele

^{17.08.2018. u 11:12 - pre 68 meseci}

Evo doradjenog koda koliko toliko

Code:

Sub Karnet()

    Dim wsOWSSvr As Worksheet, wsKarnet As Worksheet
    Dim i As Integer
    Dim iTotalDays As Integer
    Dim mZaposleni As Collection
    Dim iTotalZap As Long
    Dim curDatumOd As String, curDatumDo As String
    Dim curPrisutan As Boolean
    Dim curValue As String
    Dim curDay As Integer
    Dim curZap As Long
    Dim iKarnetTotalRows As Long
    Dim iColOffset As Integer

    On Error Resume Next

    iColOffset = 1

    ' Step 1 - Set worksheets to local var's

    ' Get worksheet 'OWSSvr' from current workbook
    Set wsOWSSvr = ActiveWorkbook.Sheets("owssvr")

    ' Get worksheet 'Karnet' from current Workbook
    Set wsKarnet = ActiveWorkbook.Sheets("Karnet")

    ' If there was any error then
    If Err.Number <> 0 Then

        ' Add 'Karent' worksheet to Workbook
        Sheets.Add.Name = "Karnet"

        ' Set Worksheet to local var
        Set wsKarnet = ActiveWorkbook.Sheets("Karnet")

        Err.Clear

    End If

    ' Step 2 - Make rows and cols in 'Karnet' worksheet

    ' Make range copy
    wsOWSSvr.Range("C:C").Copy wsKarnet.Range("A1")

    ' Remove duplicates
    wsKarnet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

    ' Get total days of current month
    iTotalDays = Day(DateSerial(Year(Now()), Month(Now()) + 1, 0))

    wsKarnet.Cells(1, 2).Resize(iTotalDays, 1).ClearContents

    For i = 1 To iTotalDays

        wsKarnet.Cells(1, 2).Offset(0, i - 1) = DateSerial(Year(Now()), Month(Now()), i)

        ' Autofit columns
        wsKarnet.Cells(1, i + 1).EntireColumn.AutoFit

    Next i

    ' Step 3: Fill data values

    ' Ukupno zapisa
    iKarnetTotalRows = wsKarnet.UsedRange.Columns(1).Rows.Count

    ' Ukupno zaposlenih
    iTotalZap = wsOWSSvr.UsedRange.Columns(1).Rows.Count

    ' Create new instance of object
    Set mZaposleni = New Collection

    ' Napravi listu zaposlenih koji se nalaze u tabeli kao kolekciju gde je vrednost ustvari Row u Worksheet-u
    For i = 2 To iTotalZap

        ' Doddaj zapis u kolekciju
        mZaposleni.Add i, wsOWSSvr.Cells(i, 3)

        ' Set default values
        wsKarnet.Range(wsKarnet.Cells(i, iColOffset + 1), wsKarnet.Cells(i, iTotalDays + iColOffset)).Value = "-"

    Next

    For i = 2 To iKarnetTotalRows

        ' Default value to set
        curValue = "-"

        ' Datum Od
        curDatumOd = wsOWSSvr.Cells(i, 1)

        ' Datum Do
        curDatumDo = wsOWSSvr.Cells(i, 2)

        ' Pristan True/False
        curPrisutan = CBool("" & wsOWSSvr.Cells(i, 5))

        ' If Prisutan is True then update current value which will be set in other worksheet
        If curPrisutan = True Then curValue = "+"

        ' Trenutni dan - na osnovu dana kreira se kolona
        curDay = CInt(Format(curDatumOd, "d")) + iColOffset

        ' Uzima se lokacija zaposlenog u tabeli
        curZap = mZaposleni(wsOWSSvr.Cells(i, 3))

        ' Dodeljuje vrednost +/-
        wsKarnet.Cells(curZap, curDay) = curValue

        Debug.Print curZap, curDatumOd, curDatumDo, curPrisutan, curDay, curValue

    Next

    ' Free memory resource
    Set mZaposleni = Nothing

End Sub

Odgovor na temu

gogi100
Goran Ljubic

Član broj: 40722
Poruke: 1064
*.static.isp.telekom.rs.

+3 Profil

Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele

^{17.08.2018. u 12:52 - pre 68 meseci}

imam jos jedna problem, postoje u sheet-u 'owssvr' startni i zavrsni datum kolone, ako je na primer startni datum 8/17/2018 a zavrsni datum 8/20/2018 i prisutnost na primer FALSE treba mi da u sheet 'Karnet' upise - 8/17/2018, 8/18/2018,8/19/2018,8/20/2018 za te datume znak '-'

Odgovor na temu

bokinet

Član broj: 29844
Poruke: 574

+50 Profil

Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele

^{17.08.2018. u 21:18 - pre 68 meseci}

1. Ako se za OD - DO, postavlja FALSE sta je onda sa ostalim vrednostima mimo tog opsega OD - DO za taj mesec?
Razlog: Podrazumevane vrednosti su vec '-' ?

2. Dodao sam kod koji radi sa OD - DO i stavlja vrednost u skladu da li je PRISUTAN True/False.
Ako pod br. 1. nije tacno (kako je navedeno u prethodnom tvom postu - odgovoru) onda je dovoljno ispraviti kod da radi azuriranje na kraju samo kada je vrednost za 'curPrisutan', TRUE.

Dodata je jedna nova promenljiva na pocetku koda.
Iskljucena prvobitna linija koda koja je postavljala jednu vrednost i dodata linija koda koja dodeljuje vrednosti za OD - DO deo.

U nastavku sledi celokupan kod koji za OD - DO stavlja + odnosno -, u zavisnosti od vrednosti 'curPrisutan':

Code:

Sub Karnet()

    Dim wsOWSSvr As Worksheet, wsKarnet As Worksheet
    Dim i As Integer
    Dim iTotalDays As Integer
    Dim mZaposleni As Collection
    Dim iTotalZap As Long
    Dim curDatumOd As String, curDatumDo As String
    Dim curPrisutan As Boolean
    Dim curValue As String
    Dim curDay As Integer
    Dim curZap As Long
    Dim iKarnetTotalRows As Long
    Dim iColOffset As Integer

    Dim iNumOfDays As Integer

    On Error Resume Next

    iColOffset = 1

    ' Step 1 - Set worksheets to local var's

    ' Get worksheet 'OWSSvr' from current workbook
    Set wsOWSSvr = ActiveWorkbook.Sheets("owssvr")

    ' Get worksheet 'Karnet' from current Workbook
    Set wsKarnet = ActiveWorkbook.Sheets("Karnet")

    ' If there was any error then
    If Err.Number <> 0 Then

        ' Add 'Karent' worksheet to Workbook
        Sheets.Add.Name = "Karnet"

        ' Set Worksheet to local var
        Set wsKarnet = ActiveWorkbook.Sheets("Karnet")

        Err.Clear

    End If

    ' Step 2 - Make rows and cols in 'Karnet' worksheet

    ' Make range copy
    wsOWSSvr.Range("C:C").Copy wsKarnet.Range("A1")

    ' Remove duplicates
    wsKarnet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

    ' Get total days of current month
    iTotalDays = Day(DateSerial(Year(Now()), Month(Now()) + 1, 0))

    wsKarnet.Cells(1, 2).Resize(iTotalDays, 1).ClearContents

    For i = 1 To iTotalDays

        wsKarnet.Cells(1, 2).Offset(0, i - 1) = DateSerial(Year(Now()), Month(Now()), i)

        ' Autofit columns
        wsKarnet.Cells(1, i + 1).EntireColumn.AutoFit

    Next i

    ' Step 3: Fill data values

    ' Ukupno zapisa
    iKarnetTotalRows = wsKarnet.UsedRange.Columns(1).Rows.Count

    ' Ukupno zaposlenih
    iTotalZap = wsOWSSvr.UsedRange.Columns(1).Rows.Count

    ' Create new instance of object
    Set mZaposleni = New Collection

    ' Napravi listu zaposlenih koji se nalaze u tabeli kao kolekciju gde je vrednost ustvari Row u Worksheet-u
    For i = 2 To iTotalZap

        ' Doddaj zapis u kolekciju
        mZaposleni.Add i, wsOWSSvr.Cells(i, 3)

        ' Set default values
        wsKarnet.Range(wsKarnet.Cells(i, iColOffset + 1), wsKarnet.Cells(i, iTotalDays + iColOffset)).Value = "-"

    Next

    For i = 2 To iKarnetTotalRows

        ' Default value to set
        curValue = "-"

        ' Datum Od
        curDatumOd = wsOWSSvr.Cells(i, 1)

        ' Datum Do
        curDatumDo = wsOWSSvr.Cells(i, 2)

        ' Broj dana izmedju dva datuma
        iNumOfDays = DateDiff("d", curDatumOd, curDatumDo)

        ' Pristan True/False
        curPrisutan = CBool("" & wsOWSSvr.Cells(i, 5))

        ' If Prisutan is True then update current value which will be set in other worksheet
        If curPrisutan = True Then curValue = "+"

        ' Trenutni dan - na osnovu dana kreira se kolona
        curDay = CInt(Format(curDatumOd, "d")) + iColOffset

        ' Uzima se lokacija zaposlenog u tabeli
        curZap = mZaposleni(wsOWSSvr.Cells(i, 3))

        ' Dodeljuje vrednost +/-
        'wsKarnet.Cells(curZap, curDay) = curValue

        ' Postavi vrednost samo za deo za datume OD - DO (Dodeljuje vrednost +/-)
        wsKarnet.Range(wsKarnet.Cells(i, curDay), wsKarnet.Cells(i, curDay + iNumOfDays)).Value = curValue

        Debug.Print curZap, curDatumOd, curDatumDo, curPrisutan, curDay, curValue

    Next

    ' Free memory resource
    Set mZaposleni = Nothing

End Sub

Odgovor na temu