utworzone przez dsp_dozorca | gru 29, 2017 | Blog, Porady, Software, Wiedza |
autor: http://www.hackwars.pl/vba-excel-pobieranie-danych-roznych-plikow/
ThisWorkbook.Path – Właściwość Path skoroszytu Excela określa pełną ścieżkę katalogu, w którym znajduje się dany plik – dzięki czemu możemy sobie odpuścić ścieżkę F:\Problem_solving, i dzięki czemu gdzie byśmy nie przenieśli katalogu głównego (Problem_solving) makro nadal będzie działać.
Workbooks.Open(Filename:=plik) – metoda odpowiedzialna za otwarcie konkretnego pliku
wb.Saved = True – zapisywanie otwartych plików – dzięki czemu przed zamknięciem nie będzie excel wyświetlał powiadomień z zapytaniem czy zapisać.
wb.Close – metoda Close – zamyka plik
KOD DLA POTOMNOŚCI
Sub problem_solving()
Application.ShowWindowsInTaskbar = False ’ wyłaczamy aktualizacje taskbara
Application.ScreenUpdating = False ’ wylaczamy aktualizacje tego co sie dzieje na ekranie podczas pracy makra
Dim kom1 As Range ’ zestawienie
Dim kom2 As Range ’ filestocheck
Dim newkom1 As Range ’ arkusz1 – dla plików z których pobieramy dane
For Each kom1 In Sheets(„zestawienie”).Range(„a4:a15”) ’ zakres w arkuszu zestawienie w którym znajdują się nazwy działów
'tworzymy i zerujemy sobie zmienne dla każdego miesiąca
styczen = 0
luty = 0
marzec = 0
kwiecien = 0
maj = 0
czerwiec = 0
lipiec = 0
sierpien = 0
wrzesien = 0
pazdziernik = 0
listopad = 0
grudzien = 0
starsze = 0
rest = 0
For Each kom2 In Sheets(„FilesToCheck”).Range(„A4:a15”) ’ zakres w arkuszu FilesToCheck w ktorym znajduja się nazwy dzialow
brak_pliku = False
If (kom1.Value = kom2.Value) Then 'jesli dzial z zestawienia bedzie sie rownal dzialowi z filestochec to wykonaj to:
lokalizacja = kom2.Offset(0, 1).Value
nazwa_pliku = kom2.Offset(0, 2).Value
kol = kom2.Offset(0, 3).Value ’ kolumna która należy przeszukiwac w plikach do sprawdzenia
wier = kom2.Offset(0, 4).Value ’ wiersz od ktorego należy rozpocząć przeszukiwania w plikach do sprawdzenia
plik = ThisWorkbook.Path & „\” & lokalizacja & „\” & nazwa_pliku ’ sciezka do konkretnego pliku
If Dir(plik) <> „” Then ’ sprawdzamy czy plik jest pusty / jesli nie jest to wchodzimy do środka
Set wb = Workbooks.Open(Filename:=plik) ’ ustawiamy zmienna wb na dany skoroszyt
wb.Worksheets(„Arkusz1”).Range(kol & wier).End(xlDown).Select ’ szukamy ostatniego wiersza do przeszukiwania
ostatni_wier = ActiveCell.Row + 1 ’ ustawiamy ostatni wolny wiersz
For Each newkom1 In wb.Worksheets(„Arkusz1”).Range(kol & wier & „:” & kol & ostatni_wier) ’ sprawdzamy zakres danych w plikach z których chcemy zebrać dane
If (newkom1.Value = „S”) Then
rok = Year(newkom1.Offset(0, -2).Value)
miesiac = Month(newkom1.Offset(0, -2).Value)
If (rok < Year(Now)) Then
starsze = starsze + 1
Else '(rok < Year(Now))
Select Case miesiac ’ instrukcja warunkowa case dzięki której mozemy podliczyć otwarte projekty w zależności od miesiąca
Case 1: styczen = styczen + 1
Case 2: luty = luty + 1
Case 3: marzec = marzec + 1
Case 4: kwiecien = kwiecien + 1
Case 5: maj = maj + 1
Case 6: czerwiec = czerwiec + 1
Case 7: lipiec = lipiec + 1
Case 8: sierpien = sierpien + 1
Case 9: wrzesien = wrzesien + 1
Case 10: pazdziernik = pazdziernik + 1
Case 11: listopad = listopad + 1
Case 12: grudzien = grudzien + 1
Case Else: rest = rest + 1
End Select
End If ’ else (rok < Year(Now))
End If '(newkom1.Value = „S”)
Next ’ end newkom1
wb.Saved = True ’ zapisujemy plik
wb.Close ’ zamykamy
Else
brak_pliku = True
Exit For
End If ’ Dir(plik) <> „”
End If '(kom1.Value = kom2.Value)
Next
’ zapisujemy dane w arkuszu zestawienie w odpowiednich komórkach (offset – przypisuje do odpowiedniego miesiaca – jest to przesunięcie względem komórki która przeszukujemy)
kom1.Offset(0, 1).Value = styczen
kom1.Offset(0, 2).Value = luty
kom1.Offset(0, 3).Value = marzec
kom1.Offset(0, 4).Value = kwiecien
kom1.Offset(0, 5).Value = maj
kom1.Offset(0, 6).Value = czerwiec
kom1.Offset(0, 7).Value = lipiec
kom1.Offset(0, 8).Value = sierpien
kom1.Offset(0, 9).Value = wrzesien
kom1.Offset(0, 10).Value = pazdziernik
kom1.Offset(0, 11).Value = listopad
kom1.Offset(0, 12).Value = grudzien
kom1.Offset(0, 13).Value = starsze
kom1.Offset(0, 15).Value = rest
kom1.Offset(0, 14).Value = brak_pliku
Next
Application.ScreenUpdating = True
Application.ShowWindowsInTaskbar = ShwWndsTask
End Sub
utworzone przez dsp_dozorca | gru 29, 2017 | Blog, Porady, Software, Wiedza |
autor http://www.hackwars.pl/vba-excel-automatyczne-tworzenie-arkuszy-o-okreslonej-nazwie/
Worksheets.Count – zwraca liczbę arkuszy w skoroszycie
Sheets.Add(After:=Sheets(Worksheets.Count)) – dodaje nowy arkusz po bieżącym
WS.Name = MonthName(i, True) – zmienia nazwę ustawionego skoroszytu na skrót nazwy kolejnego miesiąca (gdybyśmy chcieli użyć nazwy całego miesiąca zmieniamy wartość True na False)
Opis
tym wpisie przedstawiam jak automatycznie utworzyć 12 arkuszy, których nazwa jest skrótem każdego miesiąca.
Na początku utwórzmy nowy plik Excela z obsługą makr.
Jeśli w pliku znajduje się więcej niż jeden arkusz należy usunąć nadwyżkę:)
Public Sub DodajArkusze()
'deklarowanie zmiennych
Dim i As Integer
Dim WS As Worksheet
i = 1
'rozpoczęcie pętli
For i = 1 To 12
If i > Worksheets.Count Then
'jeśli i jest większa od liczby arkuszy w skoroszycie (pliku) to
'ustawia zmienną WS na nowo dodany arkusz
Set WS = Sheets.Add(After:=Sheets(Worksheets.Count))
Else
'ustawia zmienna WS na pierwszy arkusz z pętli
'tu pętla zagląda tylko za pierwszym razem
Set WS = Sheets(Worksheets.Count)
End If
'zmienia nazwę aktualnie ustawionego arkusza na skrót nazwy miesiąca
WS.Name = MonthName(i, True)
'zwiększa wartość zmiennej i o 1
Next i
End Sub
utworzone przez dsp | wrz 11, 2012 | Porady, Software, Wiedza, Z życia
Porównanie dwóch arkuszy programu Excel korzystając Makro Excela , zaznacz z duplikowane wiersze skopiować je do nowego arkusza excel.
Mamy dwa arkusze w Excelu i chcemy je porównać ze sobą . A pasujące wiersze przekopiować do nowego arkusza Excela
Może komuś będzie to przydatne
Rozwiń jeżeli nie wiesz jak zacząć i z czym się to je
Pamiętaj o zmianie parametrów pod swój arkusz czyli
-Nazwy arkuszy w CompareWorksheets Worksheets(„Arkusz1”), Worksheets(„Arkusz2”) Lub zimnń samemu
Sub Compare()
'
' Macro1 Macro
'CompareWorksheets Worksheets("WPISZ SWOJĄ NAZWE ARKUSZA"), Worksheets("WPISZ SWOJA NAZWĘ ARKUSZA DRUGIEGO ")
'
' compare two different worksheets in the active workbook
CompareWorksheets Worksheets("Arkusz1"), Worksheets("Arkusz2")
End Sub
Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim dupRow As Boolean
Dim r As Long, c As Integer, m As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer, lr3 As Long
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim dupCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Application.DisplayAlerts = True
With ws1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With ws2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
lr3 = 1
For i = 1 To lr1
dupRow = True
Application.StatusBar = "Comparing cells " & Format(i / maxR, "0 %") & "..."
For r = 1 To lr2
For c = 1 To maxC
ws1.Select
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(i, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 <> cf2 Then
dupRow = False
Exit For
Else
dupRow = True
End If
Next c
If dupRow Then
dupCount = dupCount + 1
ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, maxC)).Select
Selection.Copy
Worksheets("Sheet3").Select
Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(lr3, 1), Worksheets("Sheet3").Cells(lr3, maxC)).Select
Selection.PasteSpecial
lr3 = lr3 + 1
ws1.Select
For t = 1 To maxC
ws1.Cells(i, t).Interior.ColorIndex = 19
ws1.Cells(i, t).Select
Selection.Font.Bold = True
Next t
End If
Next r
Next i
Application.StatusBar = "Formatting the report..."
'Columns("A:IV").ColumnWidth = 10
m = dupCount
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox m & " Rows contain same values!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub
Ekipa z Vertical Horizons wielkie dzięki
utworzone przez dsp | wrz 10, 2012 | Porady, Software, Wiedza
Często e Excelu potrzebujemy zrobić porównanie dwóch kolumn i zamiast ręcznie szukać każdej pozycji można zastosować Makro.
Więc do Dzieła
Porównanie 2 kolumn w arkuszu i podświetlenie pasujących wartości.
Otwieramy arkusz excel-a, klikamy klawisz Makro
w zakładce Deweloper .
Moza posłużyć się kombinacja klawiszy ALT + F11 lub jak ktoś niema zakładki Deweloper może sobie ja włączyć
Klikamy PLIK > OPCJE >Dostosowanie wstążki i zaznaczamy „ptaszka” Przy DEWELOPER
Klikamy więc Makro i wpisujemy nazwę naszego makra nr:porównanie ( ja wpisuje bez polskich znaków )
Otworzy się następne okienko gdzie wklejamy nasz kod ( ten poniżej ) poprawimy to co zaznaczone aby dopasować do swoich potrzeb zamykamy i
UWAGA
PAMIETAJ o zmianie parametrów pod swoje potrzeby .-
– Wybieramy nazwę arkusza
-Które kolumny ma porównać ( kolumna A to 1 B to 2 itd..
-Możesz wybrać kolor zaznaczenia
A oto zbawienny kod makro który porówna nam dwie kolumny i zaznaczy powtarzające się fragmenty
Sub POROWNANIE()
Dim c1 As Integer, c2 As Integer
Dim i As Long, k As Long, count As Long
Dim lr1 As Long, lr2 As Long
Dim cf1 As String, cf2 As String
Dim WS As Worksheet
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Wpisz nazwę Arkusza
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Set WS = Worksheets("Arkusz2") ' możena tez podać numer zakładki np: Set WS = Worksheets(2)
Application.ScreenUpdating = False
Application.StatusBar = "Chwila przgotowuje raport raport..."
Application.DisplayAlerts = True
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Wpisz swoje numer kolumny które chcesz porównać w C1 oraz C2 oraz (1 to kolumna A 2 to kolumna B itd.)
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c1 = 1
c2 = 3
With WS.UsedRange
lr1 = .Rows.count
End With
For i = 2 To lr1
For k = 2 To lr1
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = WS.Cells(i, c1).FormulaLocal
cf2 = WS.Cells(k, c2).FormulaLocal
On Error GoTo 0
If cf1 = cf2 Then
count = count + 1
'Możesz zmienic kolor zamiast 46 wpisz wartość od 0-255
WS.Cells(i, c1).Interior.ColorIndex = 46
WS.Cells(i, c1).Select
Selection.Font.Bold = True
Exit For
End If
Next k
Next i
Application.StatusBar = "Przygotowuje raport......"
'Columns("A:IV").ColumnWidth = 10
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox count & " komórki zawierają te same wartości! ", vbInformation, _
"Porównano kolumnę " & c1 & " z kolumną " & c2
End Sub
I to chyba wszystko
TH team 🙂 Vertical Horizons
