Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 66706 Skopiuj do schowka Jedna kolumna -> wiele kolumn wiele wierszy
Autor Wiadomość
apollo
ExcelSpec


Pomógł: 1295 razy
Posty: 4483
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 32 raz(y) 80.88 KB

ID posta: 378047 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 662 razy
Posty: 3481
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:
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
Chcesz precyzyjną odpowiedź - zadaj precyzyjne pytanie.
ID posta: 378049 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1295 razy
Posty: 4483
Wysłany: 07-12-2019, 11:50   

umiejead napisał/a:

Co wygrałem? Może chociaż lutownicę?... :mrgreen:

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 Skopiuj do schowka
 
 
DwaNiedźwiedzie 
Excel Expert



Wersja: Win Office 2010
Pomógł: 252 razy
Posty: 632
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 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1295 razy
Posty: 4483
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 Skopiuj do schowka
 
 
Waldek 
Excel Expert


Wersja: Win Office 2019
Pomógł: 246 razy
Posty: 1076
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 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1295 razy
Posty: 4483
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 Skopiuj do schowka
 
 
DwaNiedźwiedzie 
Excel Expert



Wersja: Win Office 2010
Pomógł: 252 razy
Posty: 632
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 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2388 razy
Posty: 7816
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 :cry:

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 Skopiuj do schowka
 
 
DwaNiedźwiedzie 
Excel Expert



Wersja: Win Office 2010
Pomógł: 252 razy
Posty: 632
Wysłany: 11-12-2019, 20:27   

Oj tam, Marecki, zamień \d+;? na \w+;? i będzie hulać :)
ID posta: 378213 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1295 razy
Posty: 4483
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 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2388 razy
Posty: 7816
Wysłany: 12-12-2019, 22:40   

No w końcu doczekałem się rozwiązania. :aaa :aaa :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 :clap :clap

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 Skopiuj do schowka
 
 
Maciej Gonet 
Excel Expert


Wersja: Win Office 2016
Pomógł: 1669 razy
Posty: 5454
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

ID posta: 378363 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
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

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

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