-
Mobilarena
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
Fferi50
Topikgazda
Szia!
Excel 2010-es verziója óta elérhető a cellák tényleges színe, ezt be lehet állítani az elküldendő munkalapon, makróval:
Sub szines()
Dim wshuj As Worksheet, rngregi As Range, cl As Range
Set rngregi = Workbooks("eredeti").Sheets("eredeti").Munka1.UsedRange.SpecialCells(xlCellTypeAllFormatConditions) ' ide helyettesítsd be a forrás munkalap elérési útját
Set wshuj = Workbooks("uj").Sheets("uj") ' ide pedig az új munkalapét
For Each cl In rngregi.Cells
wshuj.Range(cl.Address).Interior.Color = cl.DisplayFormat.Interior.Color
Next
End SubElőször átmásolod az új munkalapra az adatokat értékként, formázva, majd lefuttatod a makrót.
Ha nem csak szinezés van, hanem mást is állítasz, akkor a DisplayFormat megfelelő tulajdonságait kell az adott cellához "átmásolni'. (pl. font.color, font.size stb.)
Üdv.
-
Fferi50
Topikgazda
Szia!
Mi a kérdés? Egy adott - feltételes formázású munkalapról adatokat másolnál egy másik munkafüzetbe és szeretnéd, ha a feltételes formázással megadott színekkel kerülne át (ott már nyilván a feltételes formázás nem érvényesülhet, hiszen az másik munkafüzet másik adatai alapján keletkezik.)?
Üdv.
-
-
Delila_1
veterán
Makróval megoldható.
Sub Megis_makro()
Dim usor As Long, oszlop As Integer, uoszlop As Integer
Dim ter As Range, CV As Range
Sheets("Munka1").Activate
usor = ActiveSheet.UsedRange.Rows.Count '*
uoszlop = ActiveSheet.UsedRange.Columns.Count '**
Set ter = ActiveSheet.Range(Cells(2, "A"), Cells(usor, uoszlop)) '***
oszlop = 1
For Each CV In ter
If CV > "" Then
Sheets("Munka2").Cells(CV.Row, oszlop) = CV
oszlop = oszlop + 1
End If
If CV.Column = uoszlop Then oszlop = 1
Next
End SubHárom sor végére csillagokat tettem. Ha a Munka1 lapon (ahol az eredeti adatok vannak) meghatározott területről kell kigyűjtened a Munka2 lapra az adatokat, az 1 és 2 csillagos sort töröld ki, a 3 csillagos helyett pedig ez legyen:
Set ter =Range("A2:F5"), de persze az F5 helyére a saját területed jobb alsó cellájának a címe kerüljön.
A Munka1 és Munka2 lapok nevét is írd át a saját lapjaid nevére.
-
Louro
őstag
-
-
azopi74
addikt
Vagy, esetleg csinálhatod így (úgy értettem a teljesítményt szeretnéd javítani, tehát gondolom elég nagy az adatbázis) :
Létrehozol egy új query-t az excel file-ból egy új munkalapra (monjuk "ujak"):
(Data -> Get External Data -> From Other Source -> From Microsoft Query -> Excel Files -> megadod az elésérési utat)
behúzod Munka1-ből és Munka2-ből az adatokat (név, email minekettőből),
és csinálsz egy ilyen lekérdezést (SQL gompra kattintva):SELECT `Munka2$`.Név, `Munka2$`.Email
FROM {oj `Munka2$` `Munka2$` LEFT OUTER JOIN `Munka1$` `Munka1$` ON `Munka2$`.Név & `Munka2$`.Email = `Munka1$`.Név & `Munka1$`.Email}
WHERE (`Munka1$`.Név Is Null)A makróban csak rá kell frissítened az "Ujak" munkalapra, és átmásolni Munka1-be az ujakat.
Ez így sokkal (sok adat esetén több-százszor/ezerszer) gyorsabb, mint a COUNTIF/COUNTIFS (DARABTELI és társa) vagy VLOOKUP föggvények, és ez is csak "plain" excel, nem kell hozzá külső adatbázis. Ha PowerQuery kiegészítő telepíte van (Excel 2010-től felfelé elérhető), akkor ez kissé felhasználóbarátabb módon is megoldható, mint MS Query-vel. -
Delila_1
veterán
Mindkét lapon felveszel egy új oszlopot (C), ahol összefűzöd a nevet és a címet mindegyik sorban. A képletet látod a csatolt képen. A Munka2 lap D2 cellájának a képlete =DARABTELI(Munka1!C:C;Munka1!C2)
Szűröd ezt az oszlopot nullára, a szűrt tartomány A-B oszlopát átmásolod a Munka1 lapra.
-
#24326
m.zmrzlina
senior tag
gyu84
#24323
m.zmrzlina
senior tag
Ez a pár sor át fogja másolni a Munka1 lap A1 cellában megadott nevű munkalap A1:B10 tartományát a Munka1 lap A2 cellában megadott nevű munkalap A1:B10 tartományába
Sub masol()
Dim strHonnan As String
Dim strHova As String
strHonnan = ThisWorkbook.Worksheets("Munka1").Range("A1").Value '"Munka2"
strHova = ThisWorkbook.Worksheets("Munka1").Range("A2").Value '"Munka3"
Worksheets(strHova).Range("A1:B10").Value = Worksheets(strHonnan).Range("A1:B10").Value
End Sub -
Delila_1
veterán
A két füzet és a hozzájuk tartozó lapok nevét a B1:B4 tartományba vittem be szövegként.
Sub másolás()
Dim WBInnen As String, WSInnen As String
Dim WBIde As String, WSIde As String
WBInnen = Range("B1") 'füzet neve kiterjesztéssel
WSInnen = Range("B2") 'lap neve
WBIde = Range("B3") 'füzet neve kiterjesztéssel
WSIde = Range("B4") 'lap neve
Workbooks(WBInnen).Sheets(WSInnen).Range("F1:H20").Copy Workbooks(WBIde).Sheets(WSIde).Range("D1")
End Sub -
Fferi50
Topikgazda
Szia!
Ahol a makróban a forrrás és a cél munkalap neve van, ott az adott cellára kell hivatkozni, ahova a nevet beírtad.
Pl. sheets("Munka1").range("B1").copy helyett sheets(activesheet.range("A1").value).range("B1").copyA másolandó munkalap neve az activesheet A1 cellában van.
Ugyanígy a cél munkalappal is.Ha felteszed a makródat "kamu" nevekkel, akkor még pontosabb választ kaphatsz.
Üdv.
-
Fferi50
Topikgazda
Szia!
Ehhez egy kissé meg kell variálni az fkeres és ha függvényeket, (nem írtad, milyen excel verziód van. 2010-től működik a hahiba függvény is, én ezt vetettem még be.)
Az egyszerűség kedvéért elneveztem a vizsgálandó tartományokat, az első munkafüzet tartományának neve elso, a másodiké masodik, a harmadiké harmadik.
A kigyűjtött értékek az E oszlopban vannak, a képletek a G,H,I oszlopokba kerülnek:
F1 cella képlete:
=HAHIBA(FKERES(E1;elso;2;0);HAHIBA(FKERES(E1;masodik;2;0);HAHIBA(FKERES(E1;harmadik;2;0);"")))
G1 cella képlete:
=HA(HAHIBA(FKERES(E1;harmadik;2;0);"")=F1;"";HA(HAHIBA(FKERES(E1;masodik;2;0);"")=F1;HAHIBA(FKERES(E1;harmadik;2;0);"");HA(HAHIBA(FKERES(E1;masodik;2;0);"")="";HAHIBA(FKERES(E1;harmadik;2;0);"");HAHIBA(FKERES(E1;masodik;2;0);""))))
H1 cella képlete:
=HA(HAHIBA(FKERES(E1;harmadik;2;0);"")=F1;"";HA(HAHIBA(FKERES(E1;harmadik;2;0);"")=G1;"";HAHIBA(FKERES(E1;harmadik;2;0);"")))Ezeket kell végighúzni a 3 oszlopon.
A hahiba függvény a Ha( hibás(kifejezés), hibaesetén,nem hiba esetén) összetett függvényt helyettesíti.
Üdv.
-
Delila_1
veterán
Próbáld meg a lenti makróval.
Sub Kigyujtes()
Dim sor As Long, WF As WorksheetFunction, uoszlop As Integer
Set WF = Application.WorksheetFunction
Sheets(4).Activate
sor = 1
Do While Cells(sor, 1) <> ""
uoszlop = Cells(sor, Columns.Count).End(xlToLeft).Column + 1
If WF.CountIf(Sheets(1).Columns(1), Cells(sor, 1)) > 0 Then
Cells(sor, uoszlop) = _
WF.VLookup(Cells(sor, 1), Sheets(1).Range("A:B"), 2, 0)
uoszlop = uoszlop + 1
End If
If WF.CountIf(Sheets(2).Columns(1), Cells(sor, 1)) > 0 Then
Cells(sor, uoszlop) = _
WF.VLookup(Cells(sor, 1), Sheets(2).Range("A:B"), 2, 0)
uoszlop = uoszlop + 1
End If
If WF.CountIf(Sheets(3).Columns(1), Cells(sor, 1)) > 0 Then
Cells(sor, uoszlop) = _
WF.VLookup(Cells(sor, 1), Sheets(3).Range("A:B"), 2, 0)
End If
sor = sor + 1
Loop
End Sub -
-
UBO
csendes tag
Szia!
Épp az elmúlt héten kreáltam egyet én is mert már idegesített h nem találok normálisat ami kezeli a tengely alatti értékeket is. + extraként én csináltam hozzá egy makrót ami a megadott helyre átmásolja (és áthivatkozza a megfelelő sorokat a diagrammnál), mert sajnos a userek nem szeretnek az értékek áthivatkozásával bíbelődni amikor egy másik munkalapra kéne beintegrálni
-
Fferi50
Topikgazda
Szia!
A ciklus(ok) kb. így néznének ki:
sub masolom()
set m1=sheets("Munka1") ' ahonnan másolok
set m2=sheets("Munka2") ' ahova másolok
m2sor=2 'ide jön a másolás első sora
for xx= 2 to m1.usedrange.rows.count
if not isempty(cells(xx,1)) then
for yy=2 to 13
m2.cells(m2sor,1).value=m1.cells(xx,1).value
m2.cells(m2sor,2).value=m1.cells(xx,yy).value
m2.cells(m2sor,3).value=yy-1
m2sor=m2sor+1
next
endif
next
end subElvileg a Munka1 munkalap minden sorát átmásolja a Munka2-be függőlegesen, az első oszlopba beírja mindig a terméknevet, a második oszlopba a hónap adatát, a harmadik oszlopba a hónap számát.
Üdv.
-
lappy
őstag
Sub nyomtat()
b = Worksheets("névsor").Cells(1, 2).Value
b = b + 1
For a = 2 To b
Sheets("névsor").Select
Range(Cells(a, 2), Cells(a, 2)).Select
Selection.Copy
Sheets("Sima").Select
Range("C3").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Next a
MsgBox "A nyomtatás kész, ügyes vagy!!!"
Sheets("Sima").Select
Range("C3").Select
Selection.ClearContents
Range("A2").Select
End Sub -
Fferi50
Topikgazda
Szia!
A makróban egy ciklussal végigmész a neveken, kitöltöd a nyilvántartó lapot, kiadod rá a printout parancsot (ha szükséges, előtte beállítod a pagesetup paramétereket).
A makróhoz segít a makórögzítő. Egy nyilvántartó lapot kinyomtatsz a makrórögzítővel és az eredmény lesz a ciklus belseje nagyjából. Egy kicsit bizonyára "szépíteni" kell majd rajta, de a mag az lehet.
A ciklus meg a neveket tartalmazó tartományon vagy változón megy végig.Üdv.
-
Delila_1
veterán
Próbáld meg ezt:
Sub Kitoltes()
Dim usor As Long, usor1, oszlop
usor = Columns(1).SpecialCells(xlLastCell).Row
For oszlop = 2 To 11
If Cells(usor, oszlop) = "" Then
usor1 = Cells(Rows.Count, oszlop).End(xlUp).Row
Cells(Rows.Count, oszlop).End(xlUp).Select
Selection.AutoFill Destination:=Range(Cells(usor1, oszlop), _
Cells(usor, oszlop)), Type:=xlFillDefault
End If
Next
End Sub
Új hozzászólás Aktív témák
Hirdetés
Fferi50
- Telefon felvásárlás!! Apple Watch SE/Apple Watch SE 2 (2022)
- ÁRGARANCIA!Épített KomPhone i5 13400F 16/32/64GB RAM RTX 5070 12GB GAMER PC termékbeszámítással
- AKCIÓ! Gigabyte H510M i5 10400F 16GB DDR4 512GB SSD GTX 1080Ti 11GB Rampage SHIVA Zalman 600W
- ÁRGARANCIA!Épített KomPhone i5 13400F 16/32/64GB RAM RTX 4060 Ti 8GB GAMER PC termékbeszámítással
- ÁRGARANCIA!Épített KomPhone i7 14700KF 32/64GB RAM RX 9070 XT 16GB GAMER PC termékbeszámítással
Állásajánlatok
Cég: CAMERA-PRO Hungary Kft
Város: Budapest
Cég: PC Trade Systems Kft.
Város: Szeged