ID tematu: 66706
 |
Jedna kolumna -> wiele kolumn wiele wierszy |
Autor |
Wiadomość |
apollo
ExcelSpec

Pomógł: 1306 razy Posty: 4517
|
Wysłany: 06-12-2019, 15:54 Jedna kolumna -> wiele kolumn wiele wierszy
|
|
|
Przed nami wolne dni. Kolega Marecki wraca z trasy, kolega Bill Szysz wraca ze szkolenia, a inni po prostu z pracy. Czas więc na zagadkę.
Mamy dane w A1:A100, np. 1..100, albo różne teksty. Jak napisać kod, który ładuje sto liczb 1..100 z A1:A100 do C2:L12 (11 wierszy, 10 kolumn) tak aby 1..11 w C2:C12, 12..22 w D2:D12, ..., 89:99 w K2:K12, a 100 w L2. Po prostu przekształcić 1 kolumnę w 10 kolumn. Dane wypełniają C2:L12 kolumnowo, w każdej kolumnie od góry w dół.
Warunek: nie wolno używać żadnej pętli - FOR, DO ... Loop itd.
Miłej zabawy
kolumna.JPG
|
 |
Plik ściągnięto 41 raz(y) 80.88 KB |
|
|
 | ID posta:
378047
|
|
|
 |
|
|
|
umiejead
Excel Expert

Wersja: Win Office 2013
Pomógł: 773 razy Posty: 4167
|
Wysłany: 06-12-2019, 18:31
|
|
|
Proszsz...:
Kod: | Private Sub apollo_challenge()
Dim i%, il%, k%, l%
i = 1
il = 0
k = 2
l = 3
laPocz:
If i > 100 Then Exit Sub
' opcja dla dowolnej ilości: If Cells(i, 1).Value = "" Then Exit Sub
If i Mod 11 = 0 Then
il = i / 11 + 2
Cells(12, il).Value = Cells(i, 1).Value
i = i + 1
k = 2
l = l + 1
GoTo laPocz
Else
Cells(k, l).Value = Cells(i, 1).Value
i = i + 1
k = k + 1
GoTo laPocz
End If
End Sub |
Co wygrałem? Może chociaż lutownicę?... |
_________________ .
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
Chcesz precyzyjną odpowiedź - zadaj precyzyjne pytanie. |
|
 | ID posta:
378049
|
|
|
 |
|
|
apollo
ExcelSpec

Pomógł: 1306 razy Posty: 4517
|
Wysłany: 07-12-2019, 11:50
|
|
|
umiejead napisał/a: |
Co wygrałem? Może chociaż lutownicę?... |
1. Nie wiem, czy wygrałeś, bo zabawa trwa. W tej chwili jesteś najwyżej kandydatem na wygraną.
2. Twój kod jest tylko zamaskowaną pętlą, ponieważ używa GOTO. Zauważ, że oprócz For i Do napisałem ITD. Po prostu żadne rekurencyjne wywołanie, w jakiejkolwiek postaci.
Jeśli chodzi o Twój kod to proponuję lekką modyfikację
Kod: |
Private Sub apollo_challenge()
Dim i As Long, k As Long, l As Long
i = 1
l = 2
laPocz:
If i > 100 Then Exit Sub
If i Mod 11 = 1 Then
k = 2
l = l + 1
Else
k = k + 1
End If
Cells(k, l).Value = Cells(i, 1).Value
i = i + 1
GoTo laPocz
End Sub
|
Usunąłem ' opcja dla dowolnej ilości: If Cells(i, 1).Value = "" Then Exit Sub.
Zakres zawsze musi być podany. I nie można użyć warunku Cells(i, 1).Value = "". Bo dane mogę mieć do A100, a w konkretny przypadku będę chciał ładować tylko A1:A80.
W ogólnym przypadku to mamy 3 takie dane wejściowe:
- zakres jednokolumnowy (A1:A100)
- komórka początkowa (C2)
- wymagana liczba wierszy (11)
Wymagana liczba kolumn zostanie obliczona z danych wejściowych. |
|
 | ID posta:
378052
|
|
|
 |
|
|
DwaNiedźwiedzie
Excel Expert


Wersja: Win Office 2016
Pomógł: 279 razy Posty: 686
|
Wysłany: 08-12-2019, 12:20
|
|
|
Kod: | Sub transponuj()
Set inpRng = [a1:a100]
Set destRng = [c2]
r = 11
destRng.CurrentRegion.Clear
With destRng.Resize(r, WorksheetFunction.RoundUp(inpRng.Rows.Count / r, 0))
.Formula = "=IFERROR(INDEX(" & inpRng.Address & ", ROW(A1)+(COLUMN(A1)-1)*" & r & "),"""")"
.Value2 = .Value2
End With
End Sub |
|
|
 | ID posta:
378077
|
|
|
 |
|
|
apollo
ExcelSpec

Pomógł: 1306 razy Posty: 4517
|
Wysłany: 08-12-2019, 12:46
|
|
|
@ DwaNiedźwiedzie: Tak, dziękuję. Może być.
Zawsze można użyć tylko formuły do podzielenia 1 kolumny na kilka kolumn. Jeśli ma być kod to po prostu wpisać do właściwego obszaru formuły, potem zmienić na wartość. I to robi Twój kod.
Ale formuły to po prostu obliczenie dla każdej komórki. Wiadomo, że formułą można, więc i kodem można.
Proszę o inne rozwiązanie. Ale teraz bez żadnych formuł. Bez konieczności obliczenia kolejnych komórek. Nie używać arkusza jako miejsca pośrednich obliczeń. |
|
 | ID posta:
378078
|
|
|
 |
|
|
Waldek
Excel Expert

Wersja: Win Office 2019
Pomógł: 294 razy Posty: 1300
|
Wysłany: 08-12-2019, 16:44
|
|
|
Zabawa jest bez sensu. Z każdym postem zmieniane są warunki. Warunki powinny być określone wyłącznie w pierwszym poście. Wątpię, czy kogoś jeszcze ta zabawa zainteresuje. |
|
 | ID posta:
378084
|
|
|
 |
|
|
apollo
ExcelSpec

Pomógł: 1306 razy Posty: 4517
|
Wysłany: 08-12-2019, 19:37
|
|
|
Waldek napisał/a: | Zabawa jest bez sensu. Z każdym postem zmieniane są warunki. Warunki powinny być określone wyłącznie w pierwszym poście. Wątpię, czy kogoś jeszcze ta zabawa zainteresuje. |
To tylko zabawa. To nie konkurs z nagrodą, więc nie rozumiem oburzenia.
Dla mnie zasady mogą się zmieniać. Niech będzie, że to już trochę inna zabawa. Ale co z tego, że ktoś zmienia warunki. Zawsze jeśli będą jakieś interesujące rozwiązania to wzbogacę swoją wiedzę. I O TO WŁAŚNIE CHODZI, kolego. |
|
 | ID posta:
378091
|
|
|
 |
|
|
DwaNiedźwiedzie
Excel Expert


Wersja: Win Office 2016
Pomógł: 279 razy Posty: 686
|
Wysłany: 11-12-2019, 14:29
|
|
|
No to proszę bardzo: trzy zmienne wejściowe, bez pętli, bez obliczeń w arkuszu :)
Kod: | Sub transpozycja()
Set src = [a1:a100]
Set dest = [c2]
r = 11
dest.CurrentRegion.Clear
txt = Join(WorksheetFunction.Transpose(src.Value), ";")
Set regx = CreateObject("VBScript.RegExp")
With regx
.Global = True
.Pattern = "((\d+;?){1," & r & "});?"
arr = Split(.Replace(txt, "$1|"), "|")
End With
a = UBound(arr) + 1
With dest.Resize(a, 1)
.Value = WorksheetFunction.Transpose(arr)
.TextToColumns Destination:=dest, DataType:=xlDelimited, Semicolon:=True
.Resize(r, a) = WorksheetFunction.Transpose(.Resize(a, r))
If a > r Then
.Offset(r).Resize(a - r, r).Clear
Else
.Offset(0, a - 1).Resize(, r - a + 1).Clear
End If
End With
End Sub |
|
|
 | ID posta:
378192
|
|
|
 |
|
|
Marecki
Excel Expert


Wersja: Win Office 2019
Pomógł: 2496 razy Posty: 8290
|
Wysłany: 11-12-2019, 17:39
|
|
|
DwaNiedźwiedzie, wyręczę apolla
apollo napisał/a: | Mamy dane w A1:A100, np. 1..100, albo różne teksty. | więc kombinuj dalej.
Mi do głowy nic nie przychodzi
A kiedy będzie podane rozwiązanie ??? |
_________________ Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.
Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki. |
|
 | ID posta:
378209
|
|
|
 |
|
|
DwaNiedźwiedzie
Excel Expert


Wersja: Win Office 2016
Pomógł: 279 razy Posty: 686
|
Wysłany: 11-12-2019, 20:27
|
|
|
Oj tam, Marecki, zamień \d+;? na \w+;? i będzie hulać :) |
|
 | ID posta:
378213
|
|
|
 |
|
|
apollo
ExcelSpec

Pomógł: 1306 razy Posty: 4517
|
Wysłany: 12-12-2019, 20:41
|
|
|
DwaNiedźwiedzie napisał/a: | Oj tam, Marecki, zamień \d+;? na \w+;? i będzie hulać :) |
Nie będzie jeśli np. A1 = 1,25, A2:A100 = 1..99.
Ale i tak dziękuję Tobie za rozwiązanie. Być może ktoś z Twojego rozwiązania czegoś się nauczył, np. użycia VBScript.RegExp, pomysłowości. I o to mi chodzi. Nieważne, czy rozwiązanie spełnia warunku czy nie. Zmiana warunku ma tylko 1 cel - poznanie nowych pomysłów.
Co do Twojego rozwiązania to proponuję lekką korektę. Warunek: komórki nie zawierają TAB.
Kod: |
Sub transpozycja()
Set src = [a1:a100]
Set dest = [c2]
r = 11
dest.CurrentRegion.Clear
txt = Join(WorksheetFunction.Transpose(src.Value), vbTab)
Set regx = CreateObject("VBScript.RegExp")
With regx
.Global = True
.Pattern = "(([^\t]+\t?){1," & r & "})"
arr = Split(.Replace(txt, "$1" & Chr(0)), Chr(0))
End With
a = UBound(arr) + 1
Debug.Print a
With dest.Resize(a, 1)
.Value = WorksheetFunction.Transpose(arr)
.TextToColumns Destination:=dest, DataType:=xlDelimited, Tab:=True
.Resize(r, a) = WorksheetFunction.Transpose(.Resize(a, r))
If a > r Then
.Offset(r).Resize(a - r, r).Clear
Else
.Offset(0, a - 1).Resize(, r - a + 1).Clear
End If
End With
End Sub
|
Dziękuję wszystkim za poświęcony czas.
--------------
Jeśli chodzi o moje rozwiązanie to przyznaję bez bicia, że to nie moje rozwiązanie. Tylko przypadkowo trafiłem na tę zagadkę.
Uwaga: UBound(tablica) \ wiersze + 1 to nie dokładne obliczenie. Jeśli UBound(tablica) jest podzielna przez wiersze to powstaje ostatnia dodatkowa pusta kolumna. Kod nadal działa ale ostatnia kolumna zamazuje istniejące dane, jeśli są.
Kod: |
Sub test()
Dim wiersze, kolumny As Long, cellStart As Range, tablica()
' tablica = Range("A1:A100").Value
' ReDim Preserve tablica(1 To UBound(tablica), 1 To 11)
' Range("C2,C2:L12").Value = tablica
' -------------------------------------------
tablica = Range("A1:A100").Value
wiersze = 11
kolumny = UBound(tablica) \ wiersze + 1
ReDim Preserve tablica(1 To UBound(tablica), 1 To wiersze)
Set cellStart = Range("C2")
Range(cellStart.Address & "," & cellStart.Resize(wiersze, kolumny).Address).Value = tablica
' -------------------------------------------
tablica = Range("A1:A100").Value
wiersze = 11
kolumny = UBound(tablica) \ wiersze + 1
ReDim Preserve tablica(1 To UBound(tablica), 1 To wiersze)
Set cellStart = Range("C16")
Range(cellStart.Address & "," & cellStart.Offset(3, 2).Resize(wiersze, kolumny).Address).Value = tablica
End Sub
|
|
|
 | ID posta:
378263
|
|
|
 |
|
|
Marecki
Excel Expert


Wersja: Win Office 2019
Pomógł: 2496 razy Posty: 8290
|
Wysłany: 12-12-2019, 22:40
|
|
|
No w końcu doczekałem się rozwiązania.
W życiu bym nie wpadł na takie rozwiązanie.
Tylko nie rozumiem zasady Kod: | Range("C2,C2:L12").Value = tablica | dlaczego tak się dzieje.
Chciałem podejrzeć jak wygląda tablica odwracając konstrukcję Kod: | vArr = Range("C2,C2:L12").Value | ,ale niestety tak to nie działa.
Zagadka była fajna.
Metoda Niedźwiadka też ciekawa.
Brawo Wy. |
_________________ Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.
Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki. |
|
 | ID posta:
378267
|
|
|
 |
|
|
Maciej Gonet
Excel Expert

Wersja: Win Office 2016
Pomógł: 2031 razy Posty: 6425
|
Wysłany: 14-12-2019, 17:16
|
|
|
Przyznaję, że nigdy wcześniej nie zastanawiałem się nad przypisywaniem tablic do zakresów złożonych, a okazuje się, że mamy tu kolejną nieudokumentowaną ciekawostkę Excela. Po publikacji rozwiązania zagadki postanowiłem przyjrzeć się temu dokładniej i oto co ustaliłem.
W definicji zakresu może występować kilka adresów obszarów oddzielonych przecinkami:
Kod: | Range("adres1,adres2,adres3,adres4,...") |
Jeżeli do tak zdefiniowanego zakresu przypiszemy tablicę A, to zawartość tablicy przenoszona jest pod wszystkie adresy na liście (a nie, jak można by sądzić, tylko pod pierwszy adres). Jednak o ile adresy położone na liście w miejscach nieparzystych są interpretowane w zwykły sposób – taki jak gdyby na liście był tylko jeden adres, o tyle adresy w miejscach parzystych są wypełniane danymi w sposób nietypowy.
Dotyczy to sytuacji, gdy tablica A ma strukturę dwuwymiarową. Gdy jest jednowymiarowa (wierszowa, na przykład utworzona funkcją Array) – wszystkie przypisania przebiegają standardowo.
Nietypowy sposób wypełniania obszaru polega na tym, że wielkość obszaru wynikowego jest transpozycją tablicy źródłowej: obszar wynikowy składa się z tylu wierszy, ile kolumn ma tablica źródłowa i z tylu kolumn, ile wierszy liczy tablica źródłowa. Wartości są jednak kopiowane kolumnami, to znaczy tak jakby połączyć kolejne kolumny tablicy źródłowej w jedną kolumnę, a następnie z tej kolumny wypełniać obszar docelowy również kolumna po kolumnie. Jeśli rozmiary tablicy źródłowej i obszaru docelowego są niedopasowane, kopiowana jest początkowa część połączonej tablicy źródłowej lub nadmiarowe komórki obszaru docelowego są wypełniane kodem #N/D!. Puste pola w tablicy źródłowej są kopiowane.
Przykładowy kod odtwarzający za pomocą rozwiązań klasycznych opisany wyżej nietypowy sposób wypełniania zakresu docelowego:
Kod: | Sub Odtworzenie()
Dim A, B, x, i As Long, W As Range
A = Range("A1:B4")
Set W = Range("E6").Resize(UBound(A), UBound(A, 2))
i = 1
For Each x In A 'tablica czytana kolumnami
W(i) = x 'zakres numerowany wierszami
i = i + 1
Next x
B = W
W.Clear
Set W = Nothing
Range("E6").Resize(UBound(A, 2), UBound(A)) = Application.Transpose(B)
End Sub |
Odwrotne przypisanie nie jest możliwe całościowo. Jeśli zapiszemy przypisanie:
Kod: | Dim A
A = Range("adres1,adres2,adres3,adres4") |
to skopiowany zostanie tylko pierwszy obszar, czyli tak jakbyśmy napisali:
Kod: | A = Range("adres1,adres2,adres3,adres4").Areas(1) |
Pozostałe obszary można skopiować pojedynczo w analogiczny sposób, podając odpowiedni numer obszaru.
Gdy po obu stronach instrukcji przypisania wystąpią zakresy złożone, zakres po prawej stronie musi być jawnie przekształcony w wartość (w przeciwnym razie nic nie zostanie skopiowane). Z zakresu po prawej stronie wybrany zostanie pierwszy obszar i przypisany do wszystkich obszarów zakresu po lewej stronie tak jak to opisano powyżej. (Dopisanie .Value po lewej stronie niczego nie zmienia).
Tablica_ZZ.xlsm
|
Pobierz Plik ściągnięto 57 raz(y) 14.27 KB |
|
|
 | ID posta:
378363
|
|
|
 |
|
|
|
Nie możesz pisać nowych tematów Nie możesz odpowiadać w tematach Nie możesz zmieniać swoich postów Nie możesz usuwać swoich postów Nie możesz głosować w ankietach Nie możesz załączać plików na tym forum Możesz ściągać załączniki na tym forum
|
Dodaj temat do Ulubionych Wersja do druku
|
 |
Strona używa plików cookies.
Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe
|