slow comparing values from different workbooks

G

gogi100

New Member
Joined
Aug 9, 2013
Messages
26
i have two workbooks: the first that have column 'code' with range in format 111111 displayed like text and the second workbook that have column 'code' with same range like the first workbook, but this workbook has one more column 'name'. i have task that in the first workbook i compare column 'name' with column in the second workbook and when i find same values in first workbook i insert new column 'code and name' that contains value 'code' column - 'name' column from second workbook. i created for loop but this operation is very slow because the second workbook has 5595 rows. my code is

VBA Code: 
Option Explicit
Sub CreateKontoNaziv()
Dim rng As Range
Dim DefaultRange As Range
Dim FormatRuleInput As String
Dim iCol As Long
Dim iCount As Long
Dim i As Long
Dim br As Long
Dim bk As Long
Dim PathNameSifarnikC As String
Dim PathNameSifarnikD As String
Dim PathNameSifarnikE As String
Dim PathNameSifarnikF As String
Dim PathNameSifarnikG As String
Dim CheckDirC As String
Dim CheckDirD As String
Dim CheckDirE As String
Dim CheckDirF As String
Dim CheckDirG As String
Dim owb As Workbook
Dim Sifarnik As Workbook
Dim KontoSifarnik_VInivo As Long
Dim KontoSifarnik_IVnivo As Long
Dim KontoSifarnik_IIInivo As Long
Dim KontoSifarnik_IInivo As Long
Dim j As Long
Dim fso As Object
On Error Resume Next
Set owb = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx")
On Error GoTo 0
Set fso = CreateObject("Scripting.FileSystemObject")
'Provera na kojoj se particiji nalazi sifarnik
    PathNameSifarnikC = "C:\sifarnik"
    PathNameSifarnikD = "D:\sifarnik"
    PathNameSifarnikE = "E:\sifarnik"
    PathNameSifarnikF = "F:\sifarnik"
    PathNameSifarnikG = "G:\sifarnik"
If owb Is Nothing Then
If fso.FolderExists(PathNameSifarnikC) And fso.GetDrive("C:\").DriveType = 2 Then
    Set Sifarnik = Workbooks.Open("C:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
     KontoSifarnik_VInivo = Sifarnik.Sheets("Po nivoima konta").Range("A" & Rows.count).End(xlUp).Row
     KontoSifarnik_IVnivo = Sifarnik.Sheets("Po nivoima konta").Range("D" & Rows.count).End(xlUp).Row
     KontoSifarnik_IIInivo = Sifarnik.Sheets("Po nivoima konta").Range("G" & Rows.count).End(xlUp).Row
     KontoSifarnik_IInivo = Sifarnik.Sheets("Po nivoima konta").Range("J" & Rows.count).End(xlUp).Row
    'Postavljanje ovog workbook-a da je aktivan
    ThisWorkbook.Activate
 ElseIf fso.FolderExists(PathNameSifarnikD) And fso.GetDrive("D:\").DriveType = 2 Then
     Set Sifarnik = Workbooks.Open("D:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
      KontoSifarnik_VInivo = Sifarnik.Sheets("Po nivoima konta").Range("A" & Rows.count).End(xlUp).Row
      KontoSifarnik_IVnivo = Sifarnik.Sheets("Po nivoima konta").Range("D" & Rows.count).End(xlUp).Row
      KontoSifarnik_IIInivo = Sifarnik.Sheets("Po nivoima konta").Range("G" & Rows.count).End(xlUp).Row
      KontoSifarnik_IInivo = Sifarnik.Sheets("Po nivoima konta").Range("J" & Rows.count).End(xlUp).Row
     'Postavljanje ovog workbook-a da je aktivan
     ThisWorkbook.Activate
 ElseIf fso.FolderExists(PathNameSifarnikE) And fso.GetDrive("E:\").DriveType = 2 Then
     Set Sifarnik = Workbooks.Open("E:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
      KontoSifarnik_VInivo = Sifarnik.Sheets("Po nivoima konta").Range("A" & Rows.count).End(xlUp).Row
      KontoSifarnik_IVnivo = Sifarnik.Sheets("Po nivoima konta").Range("D" & Rows.count).End(xlUp).Row
      KontoSifarnik_IIInivo = Sifarnik.Sheets("Po nivoima konta").Range("G" & Rows.count).End(xlUp).Row
      KontoSifarnik_IInivo = Sifarnik.Sheets("Po nivoima konta").Range("J" & Rows.count).End(xlUp).Row
     'Postavljanje ovog workbook-a da je aktivan
     ThisWorkbook.Activate
 ElseIf fso.FolderExists(PathNameSifarnikF) And fso.GetDrive("F:\").DriveType = 2 Then
     Set Sifarnik = Workbooks.Open("F:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
      KontoSifarnik_VInivo = Sifarnik.Sheets("Po nivoima konta").Range("A" & Rows.count).End(xlUp).Row
      KontoSifarnik_IVnivo = Sifarnik.Sheets("Po nivoima konta").Range("D" & Rows.count).End(xlUp).Row
      KontoSifarnik_IIInivo = Sifarnik.Sheets("Po nivoima konta").Range("G" & Rows.count).End(xlUp).Row
      KontoSifarnik_IInivo = Sifarnik.Sheets("Po nivoima konta").Range("J" & Rows.count).End(xlUp).Row
     'Postavljanje ovog workbook-a da je aktivan
     ThisWorkbook.Activate
 ElseIf fso.FolderExists(PathNameSifarnikG) And fso.GetDrive("G:\").DriveType = 2 Then
     Set Sifarnik = Workbooks.Open("G:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
      KontoSifarnik_VInivo = Sifarnik.Sheets("Po nivoima konta").Range("A" & Rows.count).End(xlUp).Row
      KontoSifarnik_IVnivo = Sifarnik.Sheets("Po nivoima konta").Range("D" & Rows.count).End(xlUp).Row
      KontoSifarnik_IIInivo = Sifarnik.Sheets("Po nivoima konta").Range("G" & Rows.count).End(xlUp).Row
      KontoSifarnik_IInivo = Sifarnik.Sheets("Po nivoima konta").Range("J" & Rows.count).End(xlUp).Row
     'Postavljanje ovog workbook-a da je aktivan
    ThisWorkbook.Activate
 Else
  MsgBox "Nemate sifarnik konta, u excel-u. Kreirajte folder sifarnik i prebacite u njega fajl Pravilnik o stand klas okviru i k plan.xlsx", vbOKOnly
  Exit Sub
End If
Else
      KontoSifarnik_VInivo = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Range("A" & Rows.count).End(xlUp).Row
      KontoSifarnik_IVnivo = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Range("D" & Rows.count).End(xlUp).Row
      KontoSifarnik_IIInivo = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Range("G" & Rows.count).End(xlUp).Row
      KontoSifarnik_IInivo = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Range("J" & Rows.count).End(xlUp).Row
'Postavljanje ovog workbook-a da je aktivan
ThisWorkbook.Activate
End If
'Determine a default range based on user's Selection
  If TypeName(Selection) = "Range" Then
    Set DefaultRange = Selection
  Else
    Set DefaultRange = ActiveCell
  End If

'Get A Cell Address From The User to Get Number Format From
  On Error Resume Next
    Set rng = Application.InputBox( _
      Title:="Opseg izbora konta", _
      Prompt:="Izaberi kolonu, gde su smestena konta, u formatu A1:A5", _
      Default:=DefaultRange.Address, _
      Type:=8)
      'to get the number of columns that you want to insert with an input box
        'iCount = InputBox(Prompt:="Unesite broj kolona za unos?", Default:=1)
      
'to get the column number where you want to insert the new column
iCol = InputBox _
(Prompt:= _
"Iza koje kolone zelite da unesete kolonu(e), broj kolone u formatu: 1,2,3...? ")

'loop to insert new column(s)
'For i = 1 To iCount
    Columns(iCol).EntireColumn.Offset(, 1).Insert
    
    
'Next i

' RAD SA KONTIMA
Cells(1, iCol + 1).Value = "Konto i Naziv"


  On Error GoTo 0

'Test to ensure User Did not cancel
  If rng Is Nothing Then Exit Sub
 
 'Opseg selektovane kolone
  rng.Select
 
  'Opseg sifarnika Konto
  
 
  'Petlja koja omogucava pomeranje kroz tekucu tabelu
  For br = rng.Row To rng.Row + rng.Rows.count + 1
   bk = iCol + 1
 
  'Petlja za sifarnik Po nivoima konta
  If (Len(ActiveSheet.Cells(br, rng.Column).Value) = 2) Then
   For j = 3 To KontoSifarnik_IInivo
 
   'Dodela vrednosti koloni koja spaja kolonu koja sadrzi konta na II nivou i naziva konta iz sifarnika Konta
    If ActiveSheet.Cells(br, rng.Column).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 10).Value Then
      Cells(br, bk).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 10).Value & " - " & Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 11).Value
      Columns(bk).EntireColumn.AutoFit
      Cells(br, bk).HorizontalAlignment = xlLeft
    Else
      Cells(br, bk).Value = "-"
    End If
   Next j
 
  ElseIf (Len(ActiveSheet.Cells(br, rng.Column).Value) = 3) Then
   For j = 3 To KontoSifarnik_IIInivo
    
    'Dodela vrednosti koloni koja spaja kolonu koja sadrzi konta na III nivou i naziva konta iz sifarnika Konta
        If ActiveSheet.Cells(br, rng.Column).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 7).Value Then
            Cells(br, bk).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 7).Value & " - " & Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 8).Value
            Columns(bk).EntireColumn.AutoFit
            Cells(br, bk).HorizontalAlignment = xlLeft
         Else
            Cells(br, bk).Value = "-"
        End If
    Next j
 
  ElseIf (Len(ActiveSheet.Cells(br, rng.Column).Value) = 4) Then
    For j = 3 To KontoSifarnik_IVnivo
 
    'Dodela vrednosti koloni koja spaja kolonu koja sadrzi konta na IV nivou i naziva konta iz sifarnika Konta
        If ActiveSheet.Cells(br, rng.Column).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 4).Value Then
            Cells(br, bk).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 4).Value & " - " & Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 5).Value
            Columns(bk).EntireColumn.AutoFit
            Cells(br, bk).HorizontalAlignment = xlLeft
         Else
            Cells(br, bk).Value = "-"
        End If
     Next j
 
  ElseIf (Len(ActiveSheet.Cells(br, rng.Column).Value) = 6) Then
    For j = 3 To KontoSifarnik_VInivo
 
    'Dodela vrednosti koloni koja spaja kolonu koja sadrzi konta na VI nivou i naziva konta iz sifarnika Konta
        If ActiveSheet.Cells(br, rng.Column).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 1).Value Then
            Cells(br, bk).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 1).Value & " - " & Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(j, 2).Value
            Columns(bk).EntireColumn.AutoFit
            Cells(br, bk).HorizontalAlignment = xlLeft
         Else
            Cells(br, bk).Value = "-"
        End If
    Next j
 
  End If
  Next br
End Sub
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Sort by date Sort by votes
Test the following to see if I messed something up. I made some adjustments to the code to try and shorten it up as well as do a little speedup, but without anything to test it on, I am doing it on paper so to speak.

VBA Code: 
Option Explicit
Sub CreateKontoNaziv()
'
    Dim bk                      As Long
    Dim br                      As Long
    Dim i                       As Long
    Dim iCol                    As Long
    Dim iCount                  As Long
    Dim j                       As Long
    Dim KontoSifarnik_IInivo    As Long
    Dim KontoSifarnik_IIInivo   As Long
    Dim KontoSifarnik_IVnivo    As Long
    Dim KontoSifarnik_VInivo    As Long
    Dim fso                     As Object
    Dim DefaultRange            As Range
    Dim rng                     As Range
    Dim CheckDirC               As String
    Dim CheckDirD               As String
    Dim CheckDirE               As String
    Dim CheckDirF               As String
    Dim CheckDirG               As String
    Dim FormatRuleInput         As String
    Dim PathNameSifarnikC       As String
    Dim PathNameSifarnikD       As String
    Dim PathNameSifarnikE       As String
    Dim PathNameSifarnikF       As String
    Dim PathNameSifarnikG       As String
    Dim owb                     As Workbook
    Dim Sifarnik                As Workbook
'
    On Error Resume Next
    Set owb = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx")      ' Rulebook on stand class framework and k plan
    On Error GoTo 0
'
    Set fso = CreateObject("Scripting.FileSystemObject")
'Provera na kojoj se particiji nalazi sifarnik
'Check which partition the sifarnik is on
    PathNameSifarnikC = "C:\sifarnik"
    PathNameSifarnikD = "D:\sifarnik"
    PathNameSifarnikE = "E:\sifarnik"
    PathNameSifarnikF = "F:\sifarnik"
    PathNameSifarnikG = "G:\sifarnik"
'
    If owb Is Nothing Then
        If fso.FolderExists(PathNameSifarnikC) And fso.GetDrive("C:\").DriveType = 2 Then
            Set Sifarnik = Workbooks.Open("C:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
'
        ElseIf fso.FolderExists(PathNameSifarnikD) And fso.GetDrive("D:\").DriveType = 2 Then
            Set Sifarnik = Workbooks.Open("D:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
'
        ElseIf fso.FolderExists(PathNameSifarnikE) And fso.GetDrive("E:\").DriveType = 2 Then
            Set Sifarnik = Workbooks.Open("E:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
'
        ElseIf fso.FolderExists(PathNameSifarnikF) And fso.GetDrive("F:\").DriveType = 2 Then
            Set Sifarnik = Workbooks.Open("F:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
'
        ElseIf fso.FolderExists(PathNameSifarnikG) And fso.GetDrive("G:\").DriveType = 2 Then
            Set Sifarnik = Workbooks.Open("G:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
'
        Else
            MsgBox "Nemate sifarnik konta, u excel-u. Kreirajte folder sifarnik i prebacite u njega fajl Pravilnik o stand klas okviru i k plan.xlsx", vbOKOnly
            Exit Sub
        End If
'
         KontoSifarnik_VInivo = Sifarnik.Sheets("Po nivoima konta").Range("A" & Rows.Count).End(xlUp).Row
         KontoSifarnik_IVnivo = Sifarnik.Sheets("Po nivoima konta").Range("D" & Rows.Count).End(xlUp).Row
        KontoSifarnik_IIInivo = Sifarnik.Sheets("Po nivoima konta").Range("G" & Rows.Count).End(xlUp).Row
         KontoSifarnik_IInivo = Sifarnik.Sheets("Po nivoima konta").Range("J" & Rows.Count).End(xlUp).Row
    Else
         KontoSifarnik_VInivo = owb.Sheets("Po nivoima konta").Range("A" & Rows.Count).End(xlUp).Row
         KontoSifarnik_IVnivo = owb.Sheets("Po nivoima konta").Range("D" & Rows.Count).End(xlUp).Row
        KontoSifarnik_IIInivo = owb.Sheets("Po nivoima konta").Range("G" & Rows.Count).End(xlUp).Row
         KontoSifarnik_IInivo = owb.Sheets("Po nivoima konta").Range("J" & Rows.Count).End(xlUp).Row
    End If
'
'Postavljanje ovog workbook-a da je aktivan
'Setting ThisWorkbook to be active
        ThisWorkbook.Activate
'
'Determine a default range based on user's Selection
    If TypeName(Selection) = "Range" Then
        Set DefaultRange = Selection
    Else
        Set DefaultRange = ActiveCell
    End If
'
'Get A Cell Address From The User to Get Number Format From
    On Error Resume Next
    Set rng = Application.InputBox(Title:="Opseg izbora konta", Prompt:="Izaberi kolonu, gde su " & _
            "smestena konta, u formatu A1:A5", Default:=DefaultRange.Address, Type:=8)
'to get the number of columns that you want to insert with an input box
'iCount = InputBox(Prompt:="Unesite broj kolona za unos?", Default:=1)
      
'to get the column number where you want to insert the new column
    iCol = InputBox(Prompt:="Iza koje kolone zelite da unesete kolonu(e), broj kolone u formatu: 1,2,3...? ")

'loop to insert new column(s)
'For i = 1 To iCount
    Columns(iCol).EntireColumn.Offset(, 1).Insert
'Next i

' RAD SA KONTIMA
' I WANT TO CONTINUE
    Cells(1, iCol + 1).Value = "Konto i Naziv"
'
    On Error GoTo 0
'Test to ensure User Did not cancel
    If rng Is Nothing Then Exit Sub
'
'Opseg selektovane kolone
'The range of the selected column
    rng.Select
'
'Opseg sifarnika Konto
'Sifarnik scope Account
'
'-----------------------------------------------------------------------------------------------
'
    bk = iCol + 1
'Petlja koja omogucava pomeranje kroz tekucu tabelu
'A loop that allows you to scroll through the current table
    For br = rng.Row To rng.Row + rng.Rows.Count + 1
'
'Petlja za sifarnik Po nivoima konta
'Codebook loop By account levels
        Select Case Len(ActiveSheet.Cells(br, rng.Column).Value)
            Case Is = 2
                For j = 3 To KontoSifarnik_IInivo
'
'Dodela vrednosti koloni koja spaja kolonu koja sadrzi konta na II nivou i naziva konta iz sifarnika Konta
'Assigning a value to a column that joins a column that contains Level II accounts and names the accounts from the Account Codebook
                    If ActiveSheet.Cells(br, rng.Column).Value = _
                            owb.Sheets("Po nivoima konta").Cells(j, 10).Value Then
                        Cells(br, bk).Value = owb.Sheets("Po nivoima konta").Cells(j, 10).Value & _
                                " - " & owb.Sheets("Po nivoima konta").Cells(j, 11).Value
'
                        Cells(br, bk).HorizontalAlignment = xlLeft
                    Else
                        Cells(br, bk).Value = "-"
                    End If
                Next j
            Case Is = 3
                For j = 3 To KontoSifarnik_IIInivo
'
'Dodela vrednosti koloni koja spaja kolonu koja sadrzi konta na III nivou i naziva konta iz sifarnika Konta
'Assigning a value to a column that joins a column that contains Level III accounts and names the accounts from the Account Codebook
                    If ActiveSheet.Cells(br, rng.Column).Value = _
                            owb.Sheets("Po nivoima konta").Cells(j, 7).Value Then
                        Cells(br, bk).Value = owb.Sheets("Po nivoima konta").Cells(j, 7).Value & _
                                " - " & owb.Sheets("Po nivoima konta").Cells(j, 8).Value
'
                        Cells(br, bk).HorizontalAlignment = xlLeft
                    Else
                        Cells(br, bk).Value = "-"
                    End If
                Next j
            Case Is = 4
                For j = 3 To KontoSifarnik_IVnivo
'
'Dodela vrednosti koloni koja spaja kolonu koja sadrzi konta na IV nivou i naziva konta iz sifarnika Konta
'Assigning a value to a column that joins a column that contains Level IV accounts and names the accounts from the Account Codebook
                    If ActiveSheet.Cells(br, rng.Column).Value = _
                            owb.Sheets("Po nivoima konta").Cells(j, 4).Value Then
                        Cells(br, bk).Value = owb.Sheets("Po nivoima konta").Cells(j, 4).Value & _
                                " - " & owb.Sheets("Po nivoima konta").Cells(j, 5).Value
'
                        Cells(br, bk).HorizontalAlignment = xlLeft
                    Else
                        Cells(br, bk).Value = "-"
                    End If
                Next j
            Case Is = 6
                For j = 3 To KontoSifarnik_VInivo
'
'Dodela vrednosti koloni koja spaja kolonu koja sadrzi konta na VI nivou i naziva konta iz sifarnika Konta
'Assigning a value to a column that joins a column that contains Level VI accounts and names the accounts from the Account Codebook
                    If ActiveSheet.Cells(br, rng.Column).Value = _
                            owb.Sheets("Po nivoima konta").Cells(j, 1).Value Then
                        Cells(br, bk).Value = owb.Sheets("Po nivoima konta").Cells(j, 1).Value & _
                                " - " & owb.Sheets("Po nivoima konta").Cells(j, 2).Value
'
                        Cells(br, bk).HorizontalAlignment = xlLeft
                    Else
                        Cells(br, bk).Value = "-"
                    End If
                Next j
        End Select
    Next br
'
    Columns(bk).EntireColumn.AutoFit
End Sub

Let us know your results from that please. Does it still work properly? Is it any faster?

Once you respond to those questions, I will add some more changes.
 
Upvote 0
your code is still very slow. i tryed with next code

VBA Code: 
ElseIf (Len(ActiveSheet.Cells(br, rng.Column).Value) = 6) Then 
   FindKonto = ActiveSheet.Cells(br, rng.Column).Value
   Set SifarnikKonta = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Columns("A:A").Find(What:=FindKonto, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not SifarnikKonta Is Nothing Then
    RedKonta = SifarnikKonta.Row
    Cells(br, bk).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(RedKonta, 1).Value & " - " & Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(RedKonta, 2).Value
    End If
    
  End If
  Next br
   ActiveSheet.Columns(iCol + 1).EntireColumn.AutoFit
   ActiveSheet.Columns(iCol + 1).HorizontalAlignment = xlLeft

the above code is faster, but I am still not satisfied
 
Upvote 0
i optimized my code and he is ok.

VBA Code: 
Option Explicit
Sub CreateKontoNaziv()
Dim rng As Range
Dim DefaultRange As Range
Dim iCol As Long
Dim br As Long
Dim bk As Long
Dim PathNameSifarnikC As String
Dim PathNameSifarnikD As String
Dim PathNameSifarnikE As String
Dim PathNameSifarnikF As String
Dim PathNameSifarnikG As String
Dim PathNameSifarnikH As String
Dim owb As Workbook
Dim Sifarnik As Workbook
Dim fso As Object
Dim FindKonto As String
Dim RedKonta As Long
Dim SifarnikKonta As Range

On Error Resume Next
Set owb = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx")
Set TrenutniWorkBook = ThisWorkbook
On Error GoTo 0
Set fso = CreateObject("Scripting.FileSystemObject")
'Provera na kojoj se particiji nalazi sifarnik
    PathNameSifarnikC = "C:\sifarnik"
    PathNameSifarnikD = "D:\sifarnik"
    PathNameSifarnikE = "E:\sifarnik"
    PathNameSifarnikF = "F:\sifarnik"
    PathNameSifarnikG = "G:\sifarnik"
    PathNameSifarnikH = "H:\sifarnik"
If owb Is Nothing Then
If fso.FolderExists(PathNameSifarnikC) And fso.GetDrive("C:\").DriveType = 2 Then
    Set Sifarnik = Workbooks.Open("C:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
    'Postavljanje ovog workbook-a da je aktivan
    ThisWorkbook.Activate
 ElseIf fso.FolderExists(PathNameSifarnikD) And fso.GetDrive("D:\").DriveType = 2 Then
     Set Sifarnik = Workbooks.Open("D:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
     'Postavljanje ovog workbook-a da je aktivan
    ThisWorkbook.Activate
 ElseIf fso.FolderExists(PathNameSifarnikE) And fso.GetDrive("E:\").DriveType = 2 Then
     Set Sifarnik = Workbooks.Open("E:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
     'Postavljanje ovog workbook-a da je aktivan
     ThisWorkbook.Activate
 ElseIf fso.FolderExists(PathNameSifarnikF) And fso.GetDrive("F:\").DriveType = 2 Then
     Set Sifarnik = Workbooks.Open("F:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
     'Postavljanje ovog workbook-a da je aktivan
    ThisWorkbook.Activate
 ElseIf fso.FolderExists(PathNameSifarnikG) And fso.GetDrive("G:\").DriveType = 2 Then
     Set Sifarnik = Workbooks.Open("G:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
     'Postavljanje ovog workbook-a da je aktivan
     ThisWorkbook.Activate
  ElseIf fso.FolderExists(PathNameSifarnikH) And fso.GetDrive("H:\").DriveType = 2 Then
     Set Sifarnik = Workbooks.Open("H:\sifarnik\Pravilnik o stand klas okviru i k plan.xlsx")
     
     'Postavljanje ovog workbook-a da je aktivan
    ThisWorkbook.Activate
 Else
  MsgBox "Nemate sifarnik konta, u excel-u. Kreirajte folder sifarnik i prebacite u njega fajl Pravilnik o stand klas okviru i k plan.xlsx", vbOKOnly
  Exit Sub
End If
Else
'Postavljanje ovog workbook-a da je aktivan
ThisWorkbook.Activate
End If

'Determine a default range based on user's Selection
  If TypeName(Selection) = "Range" Then
    Set DefaultRange = Selection
  Else
    Set DefaultRange = ActiveCell
  End If

'Get A Cell Address From The User to Get Number Format From
  On Error Resume Next
    Set rng = Application.InputBox( _
      Title:="Opseg izbora konta", _
      Prompt:="Izaberi kolonu, gde su smestena konta, u formatu A1:A5", _
      Default:=DefaultRange.Address, _
      Type:=8)
      'to get the number of columns that you want to insert with an input box
        'iCount = InputBox(Prompt:="Unesite broj kolona za unos?", Default:=1)
      
'to get the column number where you want to insert the new column
iCol = InputBox _
(Prompt:= _
"Iza koje kolone zelite da unesete kolonu(e), broj kolone u formatu: 1,2,3...? ")

'insert new column(s)
   
    Columns(iCol).EntireColumn.Offset(, 1).Insert
' RAD SA KONTIMA
    Cells(1, iCol + 1).Value = "Konto i Naziv"


  On Error GoTo 0

'Test to ensure User Did not cancel
  If rng Is Nothing Then Exit Sub
 
 'Opseg selektovane kolone
  rng.Select
 
  'Opseg sifarnika Konto
  
 
  'Petlja koja omogucava pomeranje kroz tekucu tabelu
 
   bk = iCol + 1
 
  For br = rng.Row To rng.Row + rng.Rows.Count + 1

'Pronalazenje sifre konta u Sifarniku i ubacivanje konto+naziv konta u tekucu tabelu
        Select Case Len(ActiveSheet.Cells(br, rng.Column).Value)
            Case Is = 2
                 FindKonto = ActiveSheet.Cells(br, rng.Column).Value
                 Set SifarnikKonta = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Columns("J:J").Find(What:=FindKonto, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
                 If Not SifarnikKonta Is Nothing Then
                  RedKonta = SifarnikKonta.Row
                  Cells(br, bk).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(RedKonta, 1).Value & " - " & Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(RedKonta, 2).Value
                 End If
            Case Is = 3
            FindKonto = ActiveSheet.Cells(br, rng.Column).Value
            Set SifarnikKonta = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Columns("G:G").Find(What:=FindKonto, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not SifarnikKonta Is Nothing Then
              RedKonta = SifarnikKonta.Row
              Cells(br, bk).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(RedKonta, 1).Value & " - " & Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(RedKonta, 2).Value
            End If
              
            Case Is = 4
               FindKonto = ActiveSheet.Cells(br, rng.Column).Value
               Set SifarnikKonta = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Columns("D:D").Find(What:=FindKonto, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
               If Not SifarnikKonta Is Nothing Then
                RedKonta = SifarnikKonta.Row
                Cells(br, bk).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(RedKonta, 1).Value & " - " & Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(RedKonta, 2).Value
               End If
            Case Is = 6
              FindKonto = ActiveSheet.Cells(br, rng.Column).Value
              Set SifarnikKonta = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Columns("A:A").Find(What:=FindKonto, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
              If Not SifarnikKonta Is Nothing Then
               RedKonta = SifarnikKonta.Row
               Cells(br, bk).Value = Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(RedKonta, 1).Value & " - " & Workbooks("Pravilnik o stand klas okviru i k plan.xlsx").Sheets("Po nivoima konta").Cells(RedKonta, 2).Value
              End If
        End Select
    Next br

   ActiveSheet.Columns(iCol + 1).EntireColumn.AutoFit
   ActiveSheet.Columns(iCol + 1).HorizontalAlignment = xlLeft
End Sub
but i have a problem. i want that my macro displaying on all workbooks. i created module in personal.xslb
 
Upvote 0
i tryed that replace
VBA Code: 
ThisWorkbook.Activate
with
VBA Code: 
ActiveWorkbook.Activate

but my macro works when workbook the 'Pravilnik o stand klas okviru i k plan.xlsx' is opened. when he has to open 'Pravilnik o stand klas okviru i k plan.xlsx' my macro does not works
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question Question
Workbook formulas copied with Sheet references in new Workbook
Replies
0
Views
399
GK039
G
P
  • Question Question
putting a snippet of code from one to another somehow
Replies
5
Views
304
Patriot2879
P
S
  • Question Question
Worksheet Change Event
Replies
2
Views
692
sspatriots
S
S
  • Solved
Working with multiple Target Ranges in Worksheet Code
Replies
3
Views
755
sspatriots
S
D
  • Locked
  • Question Question
VBA to copy only matching data from 2 csv workbooks into the "Master Workbook"
Replies
1
Views
329
RoryA
RoryA

Forum statistics

Threads
1,223,911
Messages
6,175,326
Members
452,635
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top