Navigacija
Lista poslednjih: 16, 32, 64, 128 poruka.

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

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

[ Pregleda: 857 | Odgovora: 7 ] > FB > Twit

Postavi temu Odgovori

Autor

Pretraga teme: Traži
Markiranje Štampanje RSS

gogi100
Goran Ljubic

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



+3 Profil

icon vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele17.08.2018. u 09:21 - pre 25 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
 
Odgovor na temu

gogi100
Goran Ljubic

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



+3 Profil

icon Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele17.08.2018. u 10:22 - pre 25 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: 428



+39 Profil

icon Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele17.08.2018. u 10:27 - pre 25 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: 428



+39 Profil

icon Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele17.08.2018. u 11:12 - pre 25 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: 964
*.static.isp.telekom.rs.



+3 Profil

icon Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele17.08.2018. u 12:52 - pre 25 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: 428



+39 Profil

icon Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele17.08.2018. u 21:18 - pre 25 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

gogi100
Goran Ljubic

Član broj: 40722
Poruke: 964
87.116.180.*



+3 Profil

icon Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele19.08.2018. u 19:38 - pre 25 meseci
Hvala puno
 
Odgovor na temu

bokinet

Član broj: 29844
Poruke: 428



+39 Profil

icon Re: vba za popunjavanje polja u tabeli na osnovu poredjenja vrednosti iz dve tabele20.08.2018. u 14:11 - pre 25 meseci
Nema na cemu.

Nadam se da vrsi posao i da je to to sto treba da bude.

Have a lot of fun.

 
Odgovor na temu

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

[ Pregleda: 857 | Odgovora: 7 ] > FB > Twit

Postavi temu Odgovori

Navigacija
Lista poslednjih: 16, 32, 64, 128 poruka.