Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Jedna kolumna -> wiele kolumn wiele wierszy

apollo · ExcelSpec **Pomógł:** 1295 razy Posty: 4483

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 32 raz(y) 80.88 KB

umiejead · 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ę?... :mrgreen:

apollo · ExcelSpec **Pomógł:** 1295 razy Posty: 4483

DwaNiedźwiedzie · 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

apollo · ExcelSpec **Pomógł:** 1295 razy Posty: 4483

@ 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ń.

Waldek · 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.

apollo · ExcelSpec **Pomógł:** 1295 razy Posty: 4483

DwaNiedźwiedzie · 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

Marecki · Wysłany: 11-12-2019, 17:39

DwaNiedźwiedzie, wyręczę apolla :-)

DwaNiedźwiedzie · Wysłany: 11-12-2019, 20:27

Oj tam, Marecki, zamień \d+;? na \w+;? i będzie hulać :)

apollo · ExcelSpec **Pomógł:** 1295 razy Posty: 4483

Marecki · Wysłany: 12-12-2019, 22:40

No w końcu doczekałem się rozwiązania. :aaa

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. :clap

Metoda Niedźwiadka też ciekawa.
Brawo Wy.

Maciej Gonet · 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 31 raz(y) 14.27 KB