Excel makró 2021-01

Hívatkozások:

munkafüzet (workbook: munkalapok gyűjteménye)

munkalap (worksheet: számolótábla)

oszlop (column),

sor (row)

cella : (alapelem) egy adat, képlet, utasítás

Hivatkozás tipusok

- Az A1 stílusú hivatkozás: a cellatartományt egy sztringben megadott kifejezéssel hivatkozzuk. Range(”A1”), Range(”c2”), Range(”A2:B3”), Range(”A:A”), Range(”1:1”), Range(”A1:A5,C1:C5”), Range(”A:A,C:D”).

Application.ReferenceStyle = xlA1

- Az R1C1 stílusú hivatkozás: a cellatartományt a sor- és oszlopindexek segítségével hivatkozzuk. Pl. Cells(1,1), Cells(2,3), Range(Cells(2,1), Cells(3,2)), Columns(1), Rows(1).

Application.ReferenceStyle = xlR1C1

cellák címzése

S3O2 vagy $B$3 // abszolút címzés

S[2]O[-1] vagy B3 // relatív címzés

Excel állományok közötti át hivatkozás:

'útvonal[munkafüzet]'munkalap!cella

Workbooks(1).Worksheets(1).Cells(1,1))

Workbooks(”Munkafüzet1.xlsm”).Worksheets(”Munka1”).Cells(1,1)).

Tartomány

cella1:cella2 vagy cella1..cella2

Az Excelbeli elnevezések VBA megfelelése:

B3 cella : Cells(3,2)

C4:G6 tartomány : Range(Cells(4,3),Cells(6,7))

B oszlop : Columns(2)

H, I, J oszlopokból álló tartomány : Range(Columns(8),Columns(10))

2. sor : Rows(2)

13.-tól a 16. sorig tartó tartomány : Range(Rows(13),Rows(16))

A munkalap összes cellája : Cells

Meghatározott munkalap cellái : Sheets(2).Cells

Az éppen aktuális cella : ActiveCell

(ha tartomány van kijelölve,aktuális cella akkor is csak egy van, aminek a tartalma a szerkesztőlécben látszik)

Az éppen kijelölt objektum : Selection

(cella, tartomány, rajz, diagramm)

A makró helye:

Egyéni makró munkafüzetben

(…\XLSTART\Personal.xls)

Ebben a munkafüzetben

Új munkafüzetben

A használható karakterek és a hozzájuk tartozó adattípusok:

% Integer, ! Single, # Double, $ String, @ Currency

Megjegyzés Az első értékadásnál megadott típusdeklarációs karakter később el is hagyható.

i% = 2.7 'Az i változóba 3 kerül (kerekítés)

c@ = 12345678# 'A c változóba egy Double konstanst teszünk

st$ = 3 'Az st változóba "3" kerül

st = st + st 'Az st változóba "33" kerül

Értéke adás:

Cells(1,1).Value = "Lajos"

Cells(1,1) = "Lajos"

Tulajdonság beállítás (pl. szín legyen piros)

Cells(1,1).Interior.Color = vbRed

Több tulajdonság beállítása with szerkezettel:

Sub formaz()

With Cells(1, 1).Font

.Name = "Arial"

.Color = vbRed

.Size = 12

.Bold = True

.Italic = True

End With

End Sub

Elágazás általános szerkezete

If feltétel Then

utasítások, amik akkor futnak le, ha a feltétel igaz

Else

utasítások, amik akkor futnak le, ha a feltétel hamis

End If

Számláló ciklus általános szerkezete

For ciklusváltozó = kezdőérték To végérték Step lépésköz

ciklusmag

'----

ossz = 0

For i = 1 To 10

ossz = ossz + i

Feltételes ciklus általános alakja

Do While feltétel

…

Loop

'-----------------

…

Loop Until feltétel

ossz = 0

i = 1

Do While i <= 10

ossz = ossz + i

i = i + 1

Loop

'---

ossz = 0

i = 1

ossz = ossz + i

i = i + 1

Loop Until i > 10

Adatbekérés box-al

valtozo = InputBox(szöveg, cím, alapértelmezés)

Üzenet megjeleniítése BOX-al

MsgBox szöveg, gombok, cím

Aktív cella tartalom változóba töltése

szoveg = ActiveCell.Value

Munkalap védelem illetve a feloldása:

Sub vedelembe()

ActiveSheet.Protect Password:="Jelszooo"

End Sub

Sub vedelemki()

ActiveSheet.Unprotect Password:="Jelszooo"

End Sub

Szabályok:

Nem csak modulba lehet makrót írni, hanem az egyes munkalapokhoz és a munkafüzethez is. Ha a makrókat az eddig megtanult módon, de nem modulba, hanem az egyik munkalaphoz írjuk, akkor akármelyik munkalapról indítjuk el a makrót, a cellahivatkozások mindig annak a munkalapnak a celláira fognak vonatkozni, amelyikről indítottuk őket (ha nincs bennük a munkalapot is megjelölő direkt hivatkozás).

Az eljárás hívásának kulcsszava (Call) elhagyható. Megadásakor az argumentumlistát zárójelbe kell tenni, ha elhagyjuk, akkor a zárójelet is el kell hagyni.

Formázó karakterek és jelentésük

Karakter Jelentés

0 Kötelezően beírandó számjegy (0-9).

9 Tetszőlegesen beírható számjegy (0-9).

# Tetszőlegesen beírható számjegy, szóköz, pluszjel, mínuszjel.

L Kötelezően beírandó betű.

? Tetszőlegesen beírható betű.

A Kötelezően beírandó betű vagy számjegy.

a Tetszőlegesen beírható betű vagy számjegy.

& Kötelezően beírandó karakter vagy szóköz.

C Tetszőlegesen beírható karakter vagy szóköz.

. : , ; - / A Windowsterületi beállításaitól függő ezres, tizedes, dátum- és időelválasztók.

> A következő karakterek nagybetűként jelennek meg.

< A következő karakterek kisbetűként jelennek meg.

! A beviteli maszk nem jobbról balra, hanem balról jobbra tölti fel az adatokat.

\ A következő karakterek betűhűen jelennek meg.

"" Az idézőjelek közötti karakterek betűhűen jelennek meg.

Excel objektumok néhány eseménye:

Click : kattintás

DblClick : duplakattintás

MouseMove : amikor az egérkurzor fölé kerül

A munkalap néhány eseménye:

SelectionChange : ha a munkalapon mást jelölünk ki

Change : ha bármelyik cella tartalma, vagy értéke megváltozik a munkalapon

BeforeDoubleClick : dupla kattintáskor a szerkesztő üzemmódba menetel előtt

(természetesen nem a dupla kattintás előtt)

BeforeRightClick :jobb-egérgomb kattintáskor mielőtt a gyorsmenü megjelenik

(természetesen nem a kattintás előtt)

Calculate : ha a munkalapon számítás történt

.interior : Háttér

.font : Betű

.color : Beépített szín (pl vbblue)

.colorindex : Szín: 1-56-ig számmal megadva

.bold(=true/false) : Félkövér

.italic (=true/false) : Dőlt

.value : Érték

.clearcontents : Tartalom kiürítése

.formatconditions : Feltételes formázás (.delete, .add)

Függvény készítése:

- A függvény eredményét, visszatérítési értékét úgy adhatjuk meg, hogy a függvény neve után írjuk egy = jel után.

- A függvényeknek egy vagy több argumentuma is lehet, ezeket a függvény neve után a zárójelbe adhatjuk meg vesszővel elválasztva.

- A függvény nevében nem lehet megadni számjegyet.

Function ugyanaz(arg)

ugyanaz = arg

End Function

Tömbfüggvénynek készítése.

Function negyzet_kob (szam)

negyzet_kob = Array(szam^2, szam^3)

End Function

A fenti függvény a megadott szám négyzetét és köbét adja eredményül tömbként.

A használata : F2, függvény megadása és Ctrl+Shift+Enter.

Beépített excel függvény használata

Az FKERES függvényt Visual Basic-ben így kell írni: WorksheetFunction.VLookup.

WorksheetFunction.VLookup(keresési_érték,tábla,oszlop_szám,tartományban_keres)

Application.WorkSheetFunction.Min()

ActiveWorkbook.SaveAs FileName:="Mentes.xls"

Alapértelmezésben az Option Base 0 van érvényben, azaz a tömbelemek alsó indexhatára 0.

A diagramot készítés

Sub Diagram_keszites()

Charts.Add

With ActiveChart

.ChartType = xl3DLine

.SetSourceData _

Source:=Sheets("adatok").Range("A1").CurrentRegion, _

PlotBy:=xlColumns

.Location Where:=xlLocationAsNewSheet

.HasTitle = True

.ChartTitle.Characters.Text = "Eladási adatok"

.Axes(xlValue, xlPrimary).HasTitle = True

.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = _

"Eladott darab"

.HasLegend = True

.Legend.Position = xlBottom

End With

End Sub

User form inicializállása (pufferelt tartalom kiürítése)

Private Sub UserForm_Initialize()

Szerkesztési praktikák

Sub aktiv()

ActiveCell.Value = Str(ActiveCell.Row)_ '!! parancs több sorba tördelése a jobb olvashatóság miatt

+ ", " + Str(ActiveCell.Column)

End Sub

Hogy a változókat deklarálni kelljen. Az Option Explicit (modulszintű) utasítást kell használni.

Egy összetett példa

Sub keres_tablazat()

Cells.Interior.ColorIndex = 0

i = 1 '(1,1) ponttól átlósan keressük az első nem üres cellát

j = 1

Do While Cells(i, j) = Empty

i = i + 1 ' sorokon megyünk végig

j = 1 ' sor els oszlopától indulunk

Do While Cells(i, j) = Empty And j < i

j = j + 1 'sor értékéig és a nem üres celláig lépkedünk

Loop

tsork = i 'táblázat kezd sora

toszlk = j 'táblázat kezd oszlopa

'keressük a táblázat jobb alsó sarkát

'toszlk tsork-tól keressük, hogy melyik sorig van a táblázat

Do While Cells(i, toszlk) <> Empty

i = i + 1

Loop

tsorv = i - 1 'megtaláltuk a tábla alatti els üres sort

Do While Cells(tsork, j) <> Empty

j = j + 1

Loop

toszlv = j - 1 'oszlop, ameddig tart a táblázat

'színezzük számlálós ciklussal a táblázatot

For i = tsork To tsorv

For j = toszlk To toszlv

Cells(i, j).Interior.Color = vbYellow

For i = 1 To tsork - 1 'tábla feletti sorok

For j = 1 To toszlv 'tábla feletti oszlopok

Cells(i, j).Interior.Color = vbBlack

For i = tsork To tsorv 'tábla melletti sorok

For j = 1 To toszlk - 1 'tábla elleti oszlopok

Cells(i, j).Interior.Color = vbBlack

End Sub

'---------------------------------------------------

' pdf formátumba mentés

Sub PDF()

Sheets("Adatok").Select

' fajlnev = "C:\ajanlatok\" & Range("B2").Value ' file név megadása cella tartalom alapján

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

"01urlapok.pdf", Quality:= _

xlQualityStandard, IncludeDocProperties:=True,

IgnorePrintAreas:=False, _

OpenAfterPublish:=True

Sheets("Űrlap").Select

End Sub

'-----------------

Sub Osszsor_szamitas()

osszsor = 1 ’Az osszsor értékét 1-re állítjuk

Do While Cells(osszsor, 1) <> "" ’Addig fut a ciklus, míg az A oszlopban van adat

osszsor = osszsor + 1 ’Az osszsor értékét 1-gyel növeljük

Loop ’Ciklus vége

osszsor = osszsor – 2 ’Az osszsor-ból levonunk 2-t, mert az első sor a fejléc, az utolsó üres

End Sub

'------

'Diagramok törlése

Sub DiagramTorles()

'Az önálló lapon lévőket

If Charts.Count > 0 Then

Application.DisplayAlerts = False 'Ne legyen figyelmeztető üzenet

Charts.Delete

Application.DisplayAlerts = True 'A figyelmeztetés visszakapcsolása

End If

'Az első munkalapon lévőket

If Worksheets(1).ChartObjects.Count > 0 Then

Worksheets(1).ChartObjects.Delete

End If

End Sub

'----

'Diagramkészítés

Sub Diagram()

Dim r As Range

'Az A1-es cellát tartalmazó összefüggő blokk adataiból...

Set r = Worksheets(1).Range("A1").CurrentRegion

'Egy új, üres diagram létrehozása

Charts.Add

'A diagram testreszabása

With ActiveChart

'A diagram típusa

.ChartType = xlColumnClustered

'A diagram forrásadatai és az adatsorozatok képzése (sorokból)

.SetSourceData Source:=r, PlotBy:=xlRows

'A diagram elhelyezése: objektumként az első munkalapra

.Location Where:=xlLocationAsObject, Name:=Worksheets(1).Name

End With

Worksheets(1).Activate 'Az első munkalap aktivizálása

Range("A1").Select 'Az A1-es cella kijelölése

End Sub

'-----

'A munkafüzet megnyitásakor aktivizálódik

Private Sub Workbook_Open()

'A saját menü kirakása

Call MenuKirak

End Sub

'--------------------------------------

Option Explicit

Sub kut_dupl_elteresek()

Dim i, j, n, m, yno, cnt As Long

Dim diff As Boolean

' ActiveWorkbook.Worksheets("MASODLAGOS_SZINKRON_RIPORT").Sort.SortFields.Clear

' ActiveWorkbook.Worksheets("MASODLAGOS_SZINKRON_RIPORT").Sort.SortFields.Add Key:=Range("D2:D25038"), _

' SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers

' ActiveWorkbook.Worksheets("MASODLAGOS_SZINKRON_RIPORT").Sort.SortFields.Add Key:=Range("B2:B25038"), _

' SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

' With ActiveWorkbook.Worksheets("MASODLAGOS_SZINKRON_RIPORT").Sort

' .SetRange Range("A1:EM25038")

' .Header = xlYes

' .MatchCase = False

' .Orientation = xlTopToBottom

' .SortMethod = xlPinYin

' .Apply

' End With

n = Cells(65000, 1).End(xlUp).Row

m = Cells(1, 255).End(xlToLeft).Column

cnt = Sheets("DIFF").Cells(65000, 1).End(xlUp).Row

' n = 635

' m = 20

cnt = 1

For i = 2 To n

diff = False

If Cells(i, 2) = "Y" Then

yno = i

End If

If yno <> i Then

For j = 6 To m

If Cells(yno, j).Value <> Cells(i, j).Value Then

diff = True

Cells(yno, j).Interior.ColorIndex = 3

Cells(i, j).Interior.ColorIndex = 3

cnt = cnt + 1

Sheets("DIFF").Cells(cnt, 1) = Cells(yno, 1)

Sheets("DIFF").Cells(cnt, 2) = Cells(yno, 4)

Sheets("DIFF").Cells(cnt, 3) = Cells(i, 1)

Sheets("DIFF").Cells(cnt, 4) = Cells(1, j)

Sheets("DIFF").Cells(cnt, 5) = Cells(yno, j)

Sheets("DIFF").Cells(cnt, 6) = Cells(i, j)

End If

Next j

End If

If diff Then

Cells(yno, 4).Interior.ColorIndex = 3

Cells(i, 4).Interior.ColorIndex = 3

End If

Next i

End Sub

Global conn As New ADODB.Connection

Global Cmd As New ADODB.Command

Global cmd1 As New ADODB.Command

Global rs, rs1 As Object

Global m_sql

Sub formazo()

'// Excel alakalmazás ált beállítása

Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"", False)" '// Muvelet gomsor terület kikapcsolása

Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"", True)" '// Muvelet gomsor terület bekapcsolása

Application.WindowState = xlMaximized '// státusz teljes

Application.DisplayFullScreen = True '// teljes képernyős üzemmód beállítása

Application.DisplayFullScreen = False '// teljes képernyős üzemmód kikapcsolása

Application.CutCopyMode = False '// Cellák nem másolhatóak

Application.ScreenUpdating = False '// képernyő friissítés kikapcsolása (gyorsitás)

Application.ScreenUpdating = True '// képernyő friissítés bekapcsolása

Application.DisplayFormulaBar = False '// képlet szerkesztő nem léthatósága kikapcsolása

Application.DisplayFormulaBar = True '// képlet szerkesztő nem léthatósága bekapcsolása

ActiveWindow.DisplayHeadings = False '// Fejléc láthatóság kikapcsolása

ActiveWindow.DisplayHeadings = False '// Fejléc láthatóság bekapcsolása

ActiveWindow.DisplayGridlines = False '// Gácsozat rajzolás kikapcsolása

ActiveWindow.DisplayGridlines = True '// Gácsozat rajzolás bekapcsolása

ActiveWindow.DisplayWorkbookTabs = False '// Munkapalok TABfülek kikapcsolása

ActiveWindow.DisplayWorkbookTabs = True '// Munkapalok TABfülek bekapcsolása

ActiveWindow.WindowState = xlMaximized '// képernyő meximalizásás bekapcsolása

Application.DisplayAlerts = False '// Hibaüzenetek képernyőre írásánek kikapcolása (gyorsitás)

Application.EnableCancelKey = xlDisabled '// Művelet visszavonás gomb tiltása

Application.Calculation = xlCalculationManual '// Képlet számolás manuális frissítés bekapcsolása

Application.Calculation = xlCalculationAutomatic '// Képlet számolás automatikus frissítés bekapcsolása

Application.EnableEvents = False '// Események figyelésének kikapcsolása (gyorsitás)

Worksheets("KL").DisplayPageBreaks = True '// laptörés engedélyezése

Worksheets("KL").Visible = xlVeryHidden '// munkalap elrejtése nagyon

Worksheets("KL").Visible = xlHidden '// munkalap elrejtése

Worksheets("KL").Visible = xlSheetVisible '// munkalap felfedése

Worksheets("KL").EnableOutlining = True '// Vonalzás bekapcsolása

Application.StatusBar = "Státusz sorba kiírás" '// Státusz sorba kiírás

Application.DisplayStatusBar = True '// Státusz sor láthatósá tétele

Application.DisplayStatusBar = False '// Státusz sor elrejtése

Application.DisplayStatusBar = True '// Státusz sor láthatósá tétele

'--- Munkalap

ThisWorkbook.Worksheets("KL").Protect Password:="a", DrawingObjects:=False, Contents:=True, Scenarios:=True, UserInterFaceOnly:=True '// munkalap Jelszóval zárolása/védelem bekapcsolása

ThisWorkbook.Worksheets("KL").Unprotect Password:="a" '// munkalap Jelszóval zárolása/védelem kikapcolása

End Sub

Sub kl_sql_pivot()

Dim PvtCache

Worksheets("pivote").Activate

' Képernyő frissítés ki

Application.DisplayAlerts = False

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

'---- PRIVOT adat

m_UserID = "kl" 'Credentials(0)

m_PWD = "KLkl" 'Credentials(1)

m_conn = "Provider=OraOLEDB.Oracle.1;PwdChgDlg=0;Persist Security Info=True;User ID=" & m_UserID & ";Data Source=EDWT10;Password=" & m_PWD

m_connpivot = "OLEDB;Provider=OraOLEDB.Oracle.1;PwdChgDlg=0;Persist Security Info=True;User ID=" & m_UserID & ";Data Source=EDWT10;Password=" & m_PWD

' Set PvtCache = Worksheets("pivote").PivotTables(1).PivotCache.Add(xlConnectionTypeOLEDB, m_connpivot)

' ThisWorkbook.Connections.Add (m_connpivot)

Worksheets("pivote").PivotTables(1).ManualUpdate = False

Worksheets("pivote").PivotTables(1).PivotCache.EnableRefresh = True

Worksheets("pivote").PivotTables(1).PivotCache.CommandText = "select * from HN_EBH27091.CALENDAR where 1=1 and yyyy='2019' and MONTH_NUM = 2"

Worksheets("pivote").PivotTables(1).PivotCache.Connection = m_connpivot

Worksheets("pivote").PivotTables(1).PivotFields("IS_WEEKEND").CurrentPage = "N"

Worksheets("pivote").PivotTables(1).PivotCache.Refresh

' /// Pivot kapcsolat allaphelyzetbe állítésa

Worksheets("pivote").PivotTables(1).PivotCache.Connection = "OLEDB;Provider=OraOLEDB.Oracle.1"

Worksheets("pivote").PivotTables(1).PivotCache.CommandText = ""

Worksheets("pivote").PivotTables(1).ManualUpdate = True

Worksheets("pivote").PivotTables(1).PivotCache.EnableRefresh = False

' Képernyő frissítés be

Application.DisplayAlerts = True

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

End Sub

Sub kl_sql_tbl()

Dim LastCol

Dim ActRow

Worksheets("KL").Activate

' Képernyő frissítés ki

Application.DisplayAlerts = False

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Range("A2:A2").Select

m_UserID = "kl" 'Credentials(0)

m_PWD = "KLkl" 'Credentials(1)

m_conn = "Provider=OraOLEDB.Oracle.1;PwdChgDlg=0;Persist Security Info=True;User ID=" & m_UserID & ";Data Source=EDWT10;Password=" & m_PWD

m_sql = "select * from HN_EBH27091.CALENDAR where 1=1 and yyyy='2019' and MONTH_NUM = 3"

conn.Open m_conn

Cmd.ActiveConnection = conn

Cmd.CommandType = adCmdText

' Set rs = Nothing

Cmd.CommandText = m_sql

' Cmd.CommandText = "select * from OPT_D_KSH"

Set rs = Cmd.Execute

LastCol = rs.Fields.Count - 1

' Minta : Range("A5:A5") = rs.Fields(0)

' Fejléc kiírása

For x = 0 To LastCol

Cells(1, x + 1) = rs.Fields(x).Name

' Mező tipus kiírása

For x = 0 To LastCol

Cells(2, x + 1) = rs.Fields(x).Type

ActRow = 3

Do While Not rs.EOF

'ActRow = wbkNameRiport.Worksheets(1).ActiveCell.Row + 1

For Findex = 0 To LastCol

If rs.Fields(Findex).Type = 202 Or rs.Fields(Findex).Type = 130 Or rs.Fields(Findex).Type = 129 Or rs.Fields(Findex).Type = 200 Then 'TEXT

Cells(ActRow, Findex + 1).Select

Selection.NumberFormat = "@"

Selection.HorizontalAlignment = xlLeft

Selection.VerticalAlignment = xlCenter

If Cells(ActRow, 1) = "" Then

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ThemeColor = 1

.TintAndShade = -0.249946592608417

.Weight = xlHairline

End With

Else

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ThemeColor = 1

.TintAndShade = -0.249946592608417

.Weight = xlHairline

End With

With Selection.Interior

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

.Color = 16770979

End With

End If

Cells(ActRow, Findex + 1).Value = rs.Fields(Findex).Value

End If

If rs.Fields(Findex).Type = 139 Then 'NUMBER

Cells(ActRow, Findex + 1).Select

Selection.NumberFormat = "#,##0"

Selection.HorizontalAlignment = xlRight

Selection.VerticalAlignment = xlCenter

If Cells(ActRow, 1) = "" Then

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ThemeColor = 1

.TintAndShade = -0.249946592608417

.Weight = xlHairline

End With

Else

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ThemeColor = 1

.TintAndShade = -0.249946592608417

.Weight = xlHairline

End With

With Selection.Interior

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

.Color = 16770979

End With

End If

Cells(ActRow, Findex + 1).Value = rs.Fields(Findex).Value

End If

If rs.Fields(Findex).Type = 135 Then 'DATE

Cells(ActRow, Findex + 1).Select

Selection.NumberFormat = "m/d/yyyy"

Selection.HorizontalAlignment = xlCenter

Selection.VerticalAlignment = xlCenter

If Cells(ActRow, 1) = "" Then

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ThemeColor = 1

.TintAndShade = -0.249946592608417

.Weight = xlHairline

End With

With Selection.Font

'.ThemeColor = xlThemeColorDark1

.TintAndShade = -0.499984740745262

End With

Else

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ThemeColor = 1

.TintAndShade = -0.249946592608417

.Weight = xlHairline

End With

With Selection.Interior

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

.Color = 16770979

End With

End If

Cells(ActRow, Findex + 1).Value = rs.Fields(Findex).Value

End If

Next Findex

ActRow = ActRow + 1

'ActRow = wbkNameRiport.Worksheets(1).Cells(Act + 2, StartCol).Row + 1

rs.MoveNext

Loop

conn.Close

Set conn = Nothing

'rs.Close

Set rs = Nothing

' Képernyő frissítés be

Application.DisplayAlerts = True

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

End SubGlobal conn As New ADODB.Connection