zapomniales Dir() przed Loop tj. plik=Dir()
Rozwiązań jest naprawdę sporo Zgadzam się z tym poglądem i choć autor postu chyba zasypał się w tych rejestrowanych makrach :-) to podsuwam nieco inne rozwiązanie tego zadania marek003 obawiam się uruchomienia takiego masowego wydruku na nieokreślonej drukarce (jednostronna czy dwustronna) i dlatego proponuję rozwiązanie z exportem wszystkich podzleceń...
Przed linijką: Do While art < zm + 1 dopisz linijkę: art = 2
Czy istnieje możliwość definicji zmiennej pętli do while na wybrane przez siebie liczby? Potrafię zdefiniować zmienną w ten sposób, by zwiększała się ona tak jak na przykładzie o wartość dowolnej liczby: wiersz=1 Do While Range("A" & wiersz) <> "" wiersz = wiersz + 1 Loop Chciałbym zamiast przeglądania każdego rekordu z przedziału ("wiersz+1",...
[syntax=vb]wiersz = 6 Sheets(1).Activate While Cells(wiersz, 1) <> "" Cells(wiersz, 2).Copy Sheets(Cells(wiersz, 1).Text).Range("C8") wiersz = wiersz + 1 Wend [/syntax]
[syntax=vbscript]Sub ImportujPliki() Application.ScreenUpdating = False Set b = ThisWorkbook Sciezka = "C:\PlikiExcela\" Plik = Dir(Sciezka & "*.xls*") x = 1 While Plik <> "" Set a = Workbooks.Open(Sciezka & Plik) Sheets(1).Copy After:=Workbooks("ImportujPliki.xlsm").S... a.Close False Plik = Dir x = x + 1 Wend Application.ScreenUpdating...
Co setny zostaje. [syntax=vbscript]Sub co_sto() i = 1 Do While Cells(i, 1) <> "" Rows(i).Resize(99).Delete i = i + 1 Loop End Sub[/syntax]
[syntax=vbscript]Sub Sumuj() Application.ScreenUpdating = False Katalog = "C:PlikiExcela" Plik = Dir(Katalog & "*.xls*") While Plik <> "" Set a = Workbooks.Open(Katalog & Plik) For x = 1 To Sheets.Count Sheets(x).Range("OO1").Formula = "=SUM(A1:A100)" s = s + Sheets(x).Range("OO1") Sheets(x).Range("OO1") = "" Next a.Close False Plik =...
Zobacz tak [syntax=vb]plik = Dir(sciezka & "\Dokumenty" & "\*.*") Do While plik <> "" ListaDokumenty.AddItem plik plik = Dir Loop[/syntax]
Zobacz tak: [syntax=vbscript]Sub Kopiuj_MG() Dim x As Long, n As Long Application.ScreenUpdating = False Sheets("Arkusz1").Select x = 2 Do While Range("A" & x).Value <> vbNullString If Cells(x, "C") > 1 Then Range("A" & x & ":C" & x).Copy n = Range("C" & x).Value Range("A" & x & ":C" & x + n - 2).Insert xlShiftDown...
[syntax=vbscript]Sub Konwersja() With Application.FileDialog(msoFileDialogFold... .Title = "Wybierz folder z plikami CSV" .InitialFileName = Environ("userprofile") & "\Desktop" If .Show = -1 Then f = .SelectedItems(1) End With If f = "" Then Exit Sub x = "\PlikiExcel" If Dir(f & x, vbDirectory) = "" Then MkDir (f & x) csv = f &...
Ale dlaczego pętla for? Bardziej naturalna to będzie np. taka pętla: [syntax=vbnet] Dim Y As Long Y = 1 Do While Cells(Y, 1) <> "" If Cells(Y, "B") = "" Then Cells(Y, "B") = "XXX" Y = Y + 1 Loop [/syntax]
Odpal takie makro [syntax=vb]Sub koko() r = 2 While Cells(r, 1) <> "" If Cells(r, 1) = Cells(r + 1, 1) Then Cells(r, 2) = Cells(r, 2) & vbLf & Cells(r + 1, 2) Rows(r + 1).Delete r = r - 1 End If r = r + 1 Wend End Sub [/syntax]
Trochę lekkich poprawek kodu, i rozłożenie na 2 pętle spowodowało że kod działa prawidłowo. W jednej pętli drukowało 1 plik i koniec, nie miałem pomysłu i czasu na dłuższą zabawę z tym kodem dlatego wrzucam w takiej formie w jakiej mi się udało (przetestowane, działa) [syntax=vbscript] Sub drukuj_z_raportem() Dim PPath$, buf$ Dim r As Integer Cells(1,...
Dodano po 19 Excel / VBA / wstawianie i kopiowanie wierszy z rozdzieleniem wartości
[syntax=vb]Sub Importuj() Dim Plik As String Plik = Dir("C:\DoImportu\*.txt") Do While Plik <> "" 'Tutaj to, co już umiesz, czyli import pliku (zmienna Plik) Plik = Dir Loop End Sub [/syntax]
[syntax=vbscript]Sub test() x = 1 With Sheets("lista") Do While .Cells(x, 1) <> "" Sheets("000").Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = Format(x, "000") Cells(12, 34) = .Cells(x, 1) x = x + 1 Loop End With End Sub[/syntax]
Wg podanych informacji, najprościej którąś z Do. Coś w tym rodzaju: [syntax=vb]wrs = 2 Do While Cells(wrs, 6) <> "" Cells(wrs, 4) = "ble ble ble" wrs = wrs + 1 Loop[/syntax]
[syntax=vb]Sub doBazy() r = 1 With Sheets("raport") While .Cells(r, 1) <> "" rb = Application.Match(.Cells(r, 1), Sheets("baza").Columns(1), 0) .Cells(r, 2).Resize(, 5).Copy Sheets("baza").Cells(rb, 2) r = r + 1 Wend End With End Sub [/syntax]
[syntax=vb]Do While .Cells(i, 1) <> "" If .Cells(i, 1) < #5/1/2016# Then .Rows(i).Delete ' data w formacie "amerykańskim" i = i - 1 End If i = i + 1 Loop[/syntax]
1. ^ to operator logiczny alternatywy rozłącznej. Co on tu robi? Raczej chodziło Ci o potęgowanie. Nie ma operatora potęgowania - trzeba użyć funkcji. Operator potęgowania w postaci ^ to, jeśli dobrze pamiętam, tylko Basic wykorzystywał (i Excel ;) ) 2. Rozmiar tablic dynamicznych podaje się w nawiasach kwadratowych. Nie wiem, co oznacza zapis stworzony...
Mały przykład [syntax=vb]Sub Petla() Dim licznik As Integer, ile As Integer ile = 500 'ile = Range("E1") Do While licznik < ile licznik = licznik + 1 test = Cells(licznik, 1) Loop MsgBox licznik End Sub[/syntax]
Może jakoś tak: [syntax=vbnet] sub Test() dim Fn as string, Wb as object Fn=Dir("C:\twój katalog\*.xlsx") do while (Fn <> "") set Wb=Open(Fn) Sheets(2).Select Fn=Dir loop end sub [/syntax] Tylko otwiera plik i wchodzi do 2 zakładki, nic więcej nie robi.
bez komorek [syntax=vb] Sub Workbook_BeforeClose(Cancel As Boolean) FolderName = ActiveWorkbook.Path & "\ARCHIWUM\" If Dir(FolderName, vbDirectory) = "" Then MkDir FolderName f = Dir(FolderName & "Rejestr_napraw_form_*") While f <> "" fdt = FileDateTime(f) If fdt > dtm Then dtm = fdt f = Dir Wend If Now() - dtm < 7 Then Exit Sub...
[syntax=vb] Open "C:\Plik.csv" For Input As #1 While Not EOF(1) Line Input #1, Linia a = Split(Linia, ";") Cells(x, 1) = a(1) x = x +1 Wend [/syntax] Idź tym tropem.
Ok. Zrozumiałem. napisałem małe makro dla zakresu i pętlą sprawdzanie. plik w zalączeniu. kod: Option Explicit Sub ZakresPetla1() Dim wiersz As Long For wiersz = 19 To 30 Step 1 Do While Cells(wiersz, 2).Value = Range("E16").Value Range("F16").Copy Cells(wiersz, 3).PasteSpecial wiersz = wiersz + 1 Loop Next End Sub
[syntax=vbscript]Sub OdczytajWpistest() Open "C:\wpisy.txt" For Input As #1 maxVal = 0 Do While Not EOF(1) Input #1, Kiedy If Kiedy > maxVal Then maxVal = Kiedy Loop Range("AD1") = maxVal + 1 Close #1 End Sub[/syntax]
makrem[syntax=vb]Sub usunDupKol() tRow = 3 While Cells(tRow, 1) <> "" For c = Cells(tRow, Columns.Count).End(xlToLeft).Column To 2 Step -1 If Application.CountIf(Rows(tRow), Cells(tRow, c)) > 1 Then Cells(tRow, c).Delete xlToLeft End If Next tRow = tRow + 1 Wend End Sub [/syntax]
Witaj Makrem [syntax=vb] Sub abcde() r = 1 While Cells(r, 1) <> Empty For i = 1 To 5 Cells(r + i, 1) = Cells(r, 1) & Chr(64 + i) Next r = r + 6 Wend End Sub [/syntax]
Zmodyfikuj ten kod np tak :spoko: : [syntax=vbscript]Sub filtr() a = Range("C3") b = Range("C4") i = 7 c = 0 Do While Cells(i, 3) <> "" If (Cells(i, 3) >= a) And (Cells(i, 3) <= b) Then Rows(i).EntireRow.Hidden = False c = c + 1 Else Rows(i).EntireRow.Hidden = True End If i = i + 1 Loop [A1] = c End Sub[/syntax]
Hmm, może dwie pętle? Jedna do określenia Nr wiersza, druga do wypełniania... [syntax=vb]wrs = 1 strS = "MAGMA" maks = 1000 'ustawienie maksimum, coby nie wpaść w nieskończoną Do While Cells(wrs, 6) <> strS If wrs = maks Then Exit Sub wrs = wrs + 1 Loop Do While Cells(wrs, 7) <> "SUMA" If wrs = maks Then Exit Sub wrs = wrs + 1 Cells(wrs,...
Jeżeli chodzi o sumowanie cyfr w liczbie to zostaje tylko makro, moge troszkę podpowiedzieć: Sub main() Dim c, x As Integer x = InputBox("") While x <> 0 c = c + x Mod 10 x = x \ 10 Wend MsgBox(c) End Sub
Na początku pętli [syntax=vbscript]Do While Len(ws_src.Range("E" & i)) > 0[/syntax]jest sprawdzany warunek czy długość zapisu w kolumnie E jest > 0. Eliminuje to przypadki pustych komórek i pustych tekstów. Gdybyś jeszcze chciał sprawdzać wartości zerowe to trzeba dodać nowy warunek pod spodem: [syntax=vbscript]If ws_src.Range("E" & i) = 0 Then Exit...
Może przez szukanie w pętli z wykorzystaniem obsługi błędu. Np[syntax=vb]On Error Resume Next Do While Err = 0 kol = Rows(1).Find(what:="MSISDN", lookat:=xlWhole).Column kol = Rows(1).Find(what:="Kod Sprzedawcy", lookat:=xlWhole).Column Columns(kol).Delete Loop[/syntax]
[syntax=vb]Sub Powiel() x = 1 Z = 1 While Cells(x, 10) <> "" For y = 1 To Cells(x, 11) Cells(Z, 13) = Cells(x, 10) Z = Z + 1 Next y x = x + 1 Wend End Sub [/syntax]
Trochę dziwi mnie Twój pomysł, ale proszę: [syntax=vb]Sub DodajKod() Dim Linia As Long, Kod As String Open "C:\PlikVBA.txt" For Input As #1 With ActiveWorkbook.VBProject.VBComponents("T... While Not EOF(1) Linia = Linia + 1 Input #1, Kod .InsertLines Linia, Kod Wend End With Close #1 End Sub [/syntax]
Witaj [syntax=vb] Sub bombon() Dim zakr10 As Range Set zakr10 = ThisWorkbook.Sheets("Bombonierki").Range... r = 2 While Cells(r, 1) <> vbNullString If Application.Count(zakr10.Rows(r)) > 0 Then Cells(r, 1).Interior.ColorIndex = 6 End If r = r + 1 Wend End Sub [/syntax]
[syntax=vbscript]Sub Dzialaj() Application.ScreenUpdating = False Dim Tekst As String Sciezka = "C:\PlikiExcela\" Tekst = "mój tekst" Plik = Dir(Sciezka & "\*.xls*") While Plik <> "" Call Wyszukaj(Sciezka & Plik, Tekst) Plik = Dir() Wend Set fso = CreateObject("Scripting.FileSystemObject... Set s = fso.GetFolder(Sciezka) For Each p In s.SubFolders...
A gdyby tak "zwykłym" Dir'em? [syntax=vbscript]Dim oFSO As Object, oFolder As Object, oSubFolder As Object, oSubSubFolder As Object, test As String Set oFSO = CreateObject("Scripting.FileSystemObject... Set oFolder = oFSO.GetFolder("c:\Pliki\") For Each oSubFolder In oFolder.subfolders For Each oSubSubFolder In oSubFolder.subfolders plik = Dir(oSubSubFolder.Path...
Prostym makrem można tak (wklej w kod arkusza i uruchom; zapisze w kol.A) [syntax=vbscript]Sub numerowanie() Dim w As Integer, test As String Dim licznik1 As Integer, licznik2 As Integer, licznik3 As Integer w = 3 Do While Cells(w, 5) <> "" If Cells(w, 4) = "__Element" Then licznik1 = licznik1 + 1 licznik2 = 0 licznik3 = 0 ElseIf Cells(w, 4) =...
aaa.. Formuła nie może działać w tej samej komórce Można podzielić 1 kolumne na inne dwie - przed 'w' i po 'w' zmienić jednu kolumnu tylko makrem [syntax=vb]Sub kokos() Dim c As Range Set c = Cells(1, 1) While c <> "" p = Application.WorksheetFunction.Search("w"... c) c.Offset(, 1) = Mid(c, p) c = Left(c, p - 1) Set c = c.Offset(1) Wend End Sub...
[syntax=vb] Sub DelDupl() With Sheets(1).Range("A:B") r = 2 While .Cells(r, 1) <> Empty If Application.CountIf(.Columns(1), .Cells(r, 1)) > 1 Then .Rows(r).Delete shift:=xlUp r = r - 1 End If r = r + 1 Wend End With End Sub [/syntax] jeszcze nie jest dobre?
Można spróbować przy pomocy funkcji wbudowanych, ale trochę tego dużo. Próbka na 60 wierszach. W B2 wpisujesz =A2 a dalej kopiowana formuła, jak na obrazku: http://obrazki.elektroda.pl/3680479800_1... W kolumnie C osiągniemy to samo wspomagając się takim[syntax=vb]Sub Co10() wrsSrc = 2 wrsDst = 2 Cells(wrsDst, 3) = Cells(wrsSrc, 1) Do...
Skoro tak, to może o to Ci chodzi? [syntax=vbscript]Sub Rozdziel() k = 1 While Cells(2, k) <> "" If InStr(1, Cells(2, k), "-") > 0 Then Cells(2, k + 1).EntireColumn.Insert ow = Cells(Rows.Count, k).End(xlUp).Row Range(Cells(2, k), Cells(ow, k)).TextToColumns _ Destination:=Range(Cells(2, k), Cells(ow, k)), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote,...
Argument jest typu String, więc podstaw sobie [syntax=vbscript]R = 3 While Cells(R, 2) <> "" karta = Cells(R, 2) ostW = Sheets(karta).Cells(1501, 11).End(xlUp).Row Cells(R, 3).FormulaR1C1 = "=countcellsbycolor('" & karta & "'!R1C11:R" & ostW & "C11,MENU!RC[-1])" R = R + 1 Wend[/syntax]
Myślę, że najlepsze wyniki czy nie od końca, ale od początku [syntax=vb]Sub Wstawianie_wierszy() Dim i As Long, r As Long, c As Long Application.ScreenUpdating = False i = 2 r = i While Cells(i, 11) <> Empty If Cells(i, 11) <> Cells(i + 1, 11) Then Rows(i + 1).Insert For c = 5 To 7 Cells(i + 1, c + 3) = Application.WorksheetFunction.Sum(Range(...
Można też tak. Całkiem szybko działa. Dodano po 3 jeśli czytamy większe arkusze danych (u mnie 2 sek Musisz zrobić próbę...
Tu masz proste makro: (sprawdza kolumny dopóki jest wartość w kolumnie C zaczynając od 7 wiersza Sub filtr() a = Range("C3") b = Range("C4") i = 7 Do While Cells(i, 3) <> "" If (Cells(i, 3) >= a) And (Cells(i, 3) <= b) Then Rows(i).EntireRow.Hidden...
Myślę, że zwykłe czytanie (xml potraktowane jako pliki sekwencyjne) powinno poradzić. Wklej do modułu standardowego i wypróbuj [syntax=vbscript]Option Compare Text Option Explicit Sub Proba() Dim katalog As String, plik As String, linia As String Dim licznik As Long, ko As Integer, startuj As Boolean katalog = "c:\" 'podstaw katalog z xml'ami. Slash...
Witam Pliki musisz pakować rar/zip itp. Co do ładowania danych do comboboxa odpowiedzialna jest część j.n musisz dopisać z jakiej zakładki są pobierane dane czyli [syntax=vbnet]Private Sub UserForm_Initialize() Dim i As Long i = 2 'bez nagłówka 'zapisanie do tablicy Do While Sheets("Articles").Cells(i, 1) <> "" AddItem Sheets("Articles").Cells(i,...
excel makro while arduino while instrukcja while
multiswitch unicable pioneer migaj diody styki kontaktron
skontroluj układ wydechowy renault skontroluj układ wydechowy renault
Toshiba TV nie reaguje na pilota, świeci czerwona dioda Wymiana napędu optycznego IDE na SATA w starym komputerze