EXCEL: Lehetséges egymás melletti oszlopok értékeit egy oszlopba, egymás alá új sorokba rendezni?
Sziasztok! Egy érdekes feladatot kaptam:
"Adott Excelben egy táblázat, amely A oszlopában helységneveket tartalmaz. A többi oszlopban (B,C, ...) kódok találhatók. Nincs meghatározva, hogy egy helység mellett hány kód szerepel, de legalább egy. Oldja meg függvénnyel/automatizmussal, hogy a helységnevek melletti kódok egymás alá kerüljenek! Amennyiben egy helységnévhez több kód is tartozott, a helység neve egymás alatt annyiszor szerepeljen, amennyi a kódok száma!"
Ha jól értem, akkor nekem valami ilyesmiből:
A 1 2 3 4 5 6
B 1 2 3 4
ilyet kellene csinálnom:
A 1
A 2
A 3
A 4
A 5
A 6
B 1
B 2
B 3
B 4
Lehetséges ez valahogyan, úgy hogy még automatizált is legyen? A válaszokat előre is köszönöm!
válasza:VBA szkriptet lehet rá írni, úgy nem vészes. Nekem egyszer a fordítottját kellett csinálnom, szkripttel csináltam.
De függvényekkel... hmm, érdekes.
válasza:Csak ötletelés: A cél táblában egy adott függvény ha tudja, hogy ő hányadik sorban van, akkor valahogy le kellene számolnia, hogy az annyiadik kódhoz melyik város tartozik.
A kódok ugyanígy sorban jövő számok, vagy össze-vissza kódok?
válasza:A kékkel jelölt segédtáblát szerintem nem lehet megspórolni. Remélem, érthető és jó a megoldásom.
A világos kék és a sötét zöld oszlopok az átláthatóbb gondolatmenet miatt vannak. Végül összevontam a világos zöld oszlopban a képleteket, de nem egyszerűsítettem (1-2 dolgot biztos lehetne).
válasza:Private Sub Worksheet_Change(ByVal Target As Range)
sor1 = 1
sor2 = 1
oszlop1 = 2
oszlop2 = 1
Do While IsEmpty(Worksheets("Munka1").Cells(sor1, 1).Value) = False
Do While IsEmpty(Worksheets("Munka1").Cells(sor1, oszlop1).Value) = False
Worksheets("Munka2").Cells(sor2, 1) = Cells(sor1, 1) & Cells(sor1, oszlop1)
oszlop1 = oszlop1 + 1
sor2 = sor2 + 1
Loop
sor1 = sor1 + 1
oszlop1 = 2
Loop
Példa: [link]
válasza:Na még egyszer mert lemaradt a vége:
Private Sub Worksheet_Change(ByVal Target As Range)
sor1 = 1
sor2 = 1
oszlop1 = 2
oszlop2 = 1
Do While IsEmpty(Worksheets("Munka1").Cells(sor1, 1).Value) = False
Do While IsEmpty(Worksheets("Munka1").Cells(sor1, oszlop1).Value) = False
Worksheets("Munka2").Cells(sor2, 1) = Cells(sor1, 1) & Cells(sor1, oszlop1)
oszlop1 = oszlop1 + 1
sor2 = sor2 + 1
Loop
sor1 = sor1 + 1
oszlop1 = 2
Loop
End Sub
válasza:Erre írtam, hogy szkripttel nem nagy kunszt, de én úgy értelmeztem, hogy a kérdezőnek függvénnyel kell. (?)
(#1-2)
válasza:Sziasztok! Ne haragudjatok, hogy csak ilyen sokára írok vissza. Idő közben sikerült nekem is megoldani a feladatot. A kódok egyébként bármilyen értéket felvehetnek, az eredeti formában bármennyi kód lehet egy sorban. Az én kódom így néz ki:
Sub Makró1()
Dim CountRows As Double
Dim CountColums As Integer
Dim data As Variant
CountRows = ActiveSheet.UsedRange.Rows.Count
CountColumns = ActiveSheet.UsedRange.Columns.Count
data = Range(Cells(1, 1), Cells(CountRows, CountColumns))
Dim newSheet As Worksheet
Set newSheet = Sheets.Add
newSheet.Cells(1, 1).Value = "Helység"
newSheet.Cells(1, 2).Value = "Kódok"
Dim StartRowPosition As Double
StartRowPosition = 2
Dim row_in_mainsheet As Double
row_in_mainsheet = 2
Dim column_in_mainsheet As Integer
Do While True
column_in_mainsheet = 2
Do While True
If Not IsEmpty(data(row_in_mainsheet, column_in_mainsheet)) Then
newSheet.Cells(StartRowPosition, 1).Value = data(row_in_mainsheet, 1)
newSheet.Cells(StartRowPosition, 2).Value = data(row_in_mainsheet, column_in_mainsheet)
StartRowPosition = StartRowPosition + 1
End If
If column_in_mainsheet = CountColumns Then Exit Do
column_in_mainsheet = column_in_mainsheet + 1
Loop
If row_in_mainsheet = CountRows Then Exit Do
row_in_mainsheet = row_in_mainsheet + 1
Loop
End Sub
Mindenkinek nagyon szépen köszönöm a segítségre irányuló szándékát!
válasza:Kapcsolódó kérdések:
Minden jog fenntartva © 2024, www.gyakorikerdesek.hu
GYIK | Szabályzat | Jogi nyilatkozat | Adatvédelem | Cookie beállítások | WebMinute Kft. | Facebook | Kapcsolat: info(kukac)gyakorikerdesek.hu
Ha kifogással szeretne élni valamely tartalommal kapcsolatban, kérjük jelezze e-mailes elérhetőségünkön!