Šta je novo?
Od:
Filteri

VBA-Excel-Ako neko moze da pomogne

M

mmkale

Zapažen
Učlanjen(a)
16.09.2022
Poruke
11
Poena
14
Potrebno mi je da automatizujem pregledanje zadataka u ekselu. Treba mi pomoć oko VBA koda za makro koji sam napravio, na radnom listu analiza, odnosno, potrebno mi je da makro moze da prepozna ako se doda novi radni list u ekselov fajl i da mi ne izbacuje gresku kada ima manje ili vise radnih listova i da makro sam predje u novi red ispod na radnom listu analiza. Evo i fajlau prilogu.
Ovo sve radi i ovako samo meni treba da se preradi da mogu da ubacujem novi radni list a da ga makro prepozna. Hvala unapred na pomoći.
 

Prilozi

  • inicijalni test 2022-2023.zip
    441.5 KB · Pregleda: 10
Znači treba mi VBA rešenje da sa 30 radnih listova iskopiram po jedan isti red ( 5-ti red) u Novi radni list (Analiza) i da redove spakujem jedan ispod drugog na tom novom radnom listu, počevši od 3 reda.
Uradio sam preko Makroa, ali moram da kliknem svaki put na Makro, da bi mi uradio za jedan red. Ne mogu da se snađem u VBA kodu da prepravim da mi automatski uradi odjednom svih 30 redova.
 
Kod: 
Dim s, r As Integer
r = 3
Application.CutCopyMode = False
For s = 1 To 30
 
    Worksheets(s).Range("B5:F5").Copy
    Worksheets("ANALIZA").Range("B" & r & ":" & "F" & r).PasteSpecial Paste:=xlPasteValues
 
    r = r + 1
    Next s
"s" označava index tj redni broj lista(sheet-a), oko promeniš redosled listova menja se i index, znači one koje kopiraš su prvih 30, "analiza" je 31., ako je "analiza" prvi ideš od 2 do 31, "r" je prvi red u koji kopiraš, probaj
 
Poslednja izmena:
Rick je napisao(la):
Kod: 
Dim s, r As Integer
r = 3
Application.CutCopyMode = False
For s = 1 To 30
 
    Worksheets(s).Range("B5:F5").Copy
    Worksheets("ANALIZA").Range("B" & r & ":" & "F" & r).PasteSpecial Paste:=xlPasteValues
 
    r = r + 1
    Next s
"s" označava index tj redni broj lista(sheet-a), oko promeniš redosled listova menja se i index, znači one koje kopiraš su prvih 30, "analiza" je 31., ako je "analiza" prvi ideš od 2 do 31, "r" je prvi red u koji kopiraš, probaj
Kliknite za proširenje...

Super, hvala puno, ovo završava posao.
Da li postoji mogućnost da ovo s ne ide do 30 nego da prebroji nekako radne listove pa da ide do tog broja radnih listova ili da se dodeli vrednost ove ćelije gde je count na radnom listu analiza ćelija B6. Ovo je slučaj kada mi radi manje ili više đaka od 30.
U svakom slučaju veliko hvala. Pozdrav
 
Može se prebrojiti sa: Worksheets.Count
dodeliš vrednost nekoh nekoj promenljivi:
dim brlistova
brlistova = Worksheets.Count
i zavisno od pozicije lista Analiza, promeniš for petlju npr:
for i = 1 to brlistova-1
.......

A možeš i tu vrednots dodeliti u neku ćeliju npr u g3:
Worksheets("ANALIZA").Range("G3").Value = Worksheets.Count
 
Poslednja izmena:
Rick je napisao(la):
Može se prebrojiti sa: Worksheets.Count
dodeliš vrednost nekoh nekoj promenljivi:
dim brlistova
brlistova = Worksheets.Count
i zavisno od pozicije lista Analiza, promeniš for petlju npr:
for i = 1 to brlistova-1
.......

A možeš i tu vrednots dodeliti u neku ćeliju npr u g3:
Worksheets("ANALIZA").Range("G3").Value = Worksheets.Count
Kliknite za proširenje...
Hvala puno, stvarno si veliki car.
 
Rick je napisao(la):
Može se prebrojiti sa: Worksheets.Count
Kliknite za proširenje...
Da li postoji mogućnost da se nakako iz više ekselovih fajlova (to su svi testovi koje su mi učenici radili) koje postavim npr. u određeni folder, preuzme po jedan radni list u u novi ekselov fajl. Na primer da sve testove(koji se nalaze u prvom radnom listu) iz fajlova pokupim u fajl gde mi je smešten ovaj radni list analiza, kako ne bi morao iz svakog fajla ručno da prebacujem radni list u fajl odakle bi pokrenuo analizu.. Probao sam makro sa jednim fajlom i to radi ali kako kad ima više fajlova koji se različito zovu. Pronašao sam da postoji mogućnost da se od više radnih listova napravi po jedan ekselov fajl tj. radna knjiga ali ovo bi bila suprotna operacija.
https://hr.excel-lib.net/11705271-split-each-excel-sheet-into-separate-files-step-by-step
U svakom slučaju si mi mnogo pomogao i do sada. Ovo bi ako je uopšte moguče da se uradi, automatizovalo celu operaciju pregledanja.
 
www.ablebits.com

How to merge Excel files into one

Three ways to merge multiple Excel files into one: by copying sheet tabs, running VBA, and using the Copy Worksheets tool.
www.ablebits.com www.ablebits.com

Imaš na dnu stranice link da skineš excel fajl sa makroom pošto ima neka greška u kodu na stranici ili ga iskopiraš:

Kod: 
Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If (vbBoolean <> VarType(fnameList)) Then
 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
         
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook
         
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
             
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
             
                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Next
             
                wbkSrcBook.Close SaveChanges:=False
             
            Next
         
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic

            MsgBox "Procesed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If
     
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

Ako želiš samo prvu stranicu u izabranim fajlovima malo izmeniš kod:
Kod: 
'For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                '   wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                'Next
                wbkSrcBook.Sheets(1).Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
 
Poslednja izmena:
Možeš dodati i inputbox za unos stranice:
......
Dim str As Integer
str = Application.InputBox("Rbr stranice:")
......
wbkSrcBook.Sheets(str).Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
.....
 
Rick je napisao(la):
www.ablebits.com

How to merge Excel files into one

Three ways to merge multiple Excel files into one: by copying sheet tabs, running VBA, and using the Copy Worksheets tool.
www.ablebits.com www.ablebits.com

Imaš na dnu stranice link da skineš excel fajl sa makroom pošto ima neka greška u kodu na stranici ili ga iskopiraš:

Kod: 
Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
   
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
   
    If (vbBoolean <> VarType(fnameList)) Then
   
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
           
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook
           
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
               
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
               
                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Next
               
                wbkSrcBook.Close SaveChanges:=False
               
            Next
           
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic

            MsgBox "Procesed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If
       
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub
Kliknite za proširenje...
nešto ne radi ili ja ne umem da se snađem
 
Radi, provereno. Kod u spojeleru ili skineš excel, ne onaj html. Izabereš fajlove(sa Shift ili CTrl) koje želiš da spojiš i to je to.

Pazi na komentare - apostrof, to je izbačeni kod:
'For Each....

Šta tačno ne radi?
 
Rick je napisao(la):
Radi, provereno. Kod u spojeleru ili skineš excel, ne onaj html. Izabereš fajlove(sa Shift ili CTrl) koje želiš da spojiš i to je to.

Pazi na komentare - apostrof, to je izbačeni kod:
'For Each....

Šta tačno ne radi?
Kliknite za proširenje...
jel ovo kod?
 

Prilozi

  • kod.txt
    1.6 KB · Pregleda: 5
Rick je napisao(la):
Radi, provereno. Kod u spojeleru ili skineš excel, ne onaj html. Izabereš fajlove(sa Shift ili CTrl) koje želiš da spojiš i to je to.

Pazi na komentare - apostrof, to je izbačeni kod:
'For Each....

Šta tačno ne radi?
Kliknite za proširenje...
Radi konačno sam uspeo. Super
Nisam ukapirao ono što ste mi napisali za broj strana..
gde da ubacim taj kod, i za šta je
 
str se odnosi: Redni broj sheet-a/tj lista ne broj strana, ako taj test ima više sheet-ova izabereš koji da spaja, npr samo prvi. Oginalna verzija spaja sve sheet-ove u svim fajlovima.

Kod: 
Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
    Dim str As Integer
str = Application.InputBox("Rbr lista/sheet-a:")
 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If (vbBoolean <> VarType(fnameList)) Then
 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
       
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook
       
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
           
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
           
               
                    countSheets = countSheets + 1
               
                wbkSrcBook.Sheets(str).Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
           
                wbkSrcBook.Close SaveChanges:=False
           
            Next
       
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic

            MsgBox "Procesed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If
   
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub
 
Rick je napisao(la):
str se odnosi: Redni broj sheet-a/tj lista ne broj strana, ako taj test ima više sheet-ova izabereš koji da spaja, npr samo prvi. Oginalna verzija spaja sve sheet-ove u svim fajlovima.

Kod: 
Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
    Dim str As Integer
str = Application.InputBox("Rbr lista/sheet-a:")
 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If (vbBoolean <> VarType(fnameList)) Then
 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
      
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook
      
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
          
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
          
              
                    countSheets = countSheets + 1
              
                wbkSrcBook.Sheets(str).Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
          
                wbkSrcBook.Close SaveChanges:=False
          
            Next
      
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic

            MsgBox "Procesed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If
  
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub
Kliknite za proširenje...
Ukapirao! Hvala na trudu i pomoći. Pozdrav
 
Morate se prijaviti ili registrovati da odgovorite ovde.
Nazad
Vrh Dno