Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Przeróbka formuły użytkownika "NAKOLUMNY"

M0nique · słuchacz **Pomógł:** 1 raz Posty: 12

Zwracam się z prośbą o zmodyfikowanie poniższeg kodu formuły "=nakolumny(zakres;ilekolumn)" użytkownika.

Zależało by mi, aby do powyższej formuły dodać 3 parametr mówiący,
które kolumny mają zostać przepisane (powtórzone), w wierszach poniżej.

"=nakolumny(zakres;kolumny_powtarzające;ilekolumn)"

Dokładnie o co mi się rozchodzi w załączniku.

Kod:

Kod:

Option Explicit

Function NaKolumny(zakres As Range, ilekolumn As Integer) As Variant

Dim tblDane, iTbl As Long, jTbl As Integer
Dim tblWyniki(), lp, w As Long, i As Integer

tblDane = zakres
On Error Resume Next
For iTbl = LBound(tblDane, 1) To UBound(tblDane, 1)
lp = tblDane(iTbl, 1)
For jTbl = LBound(tblDane, 2) + 1 To UBound(tblDane, 2) Step ilekolumn - 1
If tblDane(iTbl, jTbl) <> "" Then
w = w + 1
ReDim Preserve tblWyniki(1 To ilekolumn, 1 To w)
For i = 1 To ilekolumn
Select Case i
Case 1: tblWyniki(1, w) = lp
Case Else:
tblWyniki(i, w) = tblDane(iTbl, jTbl + i - 2)
End Select
Next
End If
Next
Next

NaKolumny = Transponuj2(tblWyniki)

End Function

Private Function Transponuj2(tabl As Variant) As Variant

Dim X As Long, Y As Long
Dim Max2 As Long, Max1 As Long
Dim Min2 As Long, Min1 As Long
Dim tempTabl As Variant

Max2 = UBound(tabl, 2)
Max1 = UBound(tabl, 1)
Min2 = LBound(tabl, 2)
Min1 = LBound(tabl, 1)

ReDim tempTabl(Min2 To Max2, Min1 To Max1)
For X = Min2 To Max2
For Y = Min1 To Max1
tempTabl(X, Y) = tabl(Y, X)
Next Y
Next X

Transponuj2 = tempTabl

End Function

Z góry dziękuję za pomoc

Przyklad.zip

Pobierz Plik ściągnięto 11 raz(y) 10.58 KB

negatyv · Wysłany: 2012-02-07, 12:10

Funkcja nakolumny powinna wyglądać tak:

Kod:

Function NaKolumny(zakres As Range, ilekolumn As Integer, naglowek As Integer) As Variant

Dim tblDane, iTbl As Long, jTbl As Integer
Dim tblWyniki(), w As Long, i As Integer

tblDane = zakres
On Error Resume Next
For iTbl = LBound(tblDane, 1) To UBound(tblDane, 1)

For jTbl = LBound(tblDane, 2) + 1 To UBound(tblDane, 2) Step ilekolumn - 1
If tblDane(iTbl, jTbl) <> "" Then
w = w + 1
ReDim Preserve tblWyniki(1 To ilekolumn + naglowek, 1 To w)
For i = 1 To ilekolumn + naglowek
Select Case i
Case Is <= naglowek: tblWyniki(i, w) = tblDane(iTbl, i)
Case Else:
tblWyniki(i, w) = tblDane(iTbl, jTbl + i - 2)
End Select
Next
End If
Next
Next

NaKolumny = Transponuj2(tblWyniki)

End Function

wuzeq · Excel Expert **Pomógł:** 142 razy Posty: 451

zobacz
=NaKolumny(D2:P4;1;2) dla pierwszego przykładu
=NaKolumny(D29:R31;3;2) dla drugiego przykladu

Kod:

Function NaKolumny(zakres As Range, ilePocz As Integer, ilekolumn As Integer) As Variant

Dim tblDane, iTbl As Long, jTbl As Integer
Dim tblWyniki(), lp, w As Long, i As Integer

tblDane = zakres
On Error Resume Next
For iTbl = LBound(tblDane, 1) To UBound(tblDane, 1)
For jTbl = LBound(tblDane, 2) + ilePocz To UBound(tblDane, 2) Step ilekolumn
If tblDane(iTbl, jTbl) <> "" Then
w = w + 1
ReDim Preserve tblWyniki(1 To ilekolumn + ilePocz, 1 To w)
For i = 1 To ilekolumn + ilePocz
Select Case i
Case 1 To ilePocz: tblWyniki(i, w) = tblDane(iTbl, i)
Case Else:
tblWyniki(i, w) = tblDane(iTbl, jTbl + i - ilePocz - 1)
End Select
Next
End If
Next
Next

NaKolumny = Transponuj2(tblWyniki)

End Function

;P

negatyv · Wysłany: 2012-02-07, 12:12

Zmienna nagłówek określa ile kolumn ma traktować tak jak pierwszą w oryginalnej funkcji.

[ Dodano: 2012-02-07, 12:13 ]
pierwszy ;)

[ Dodano: 2012-02-07, 13:35 ]
Nagłówek funkcji możesz sobie jeszcze zmienić na

Kod:

Function NaKolumny(zakres As Range, ilekolumn As Integer, Optional naglowek As Integer = 1) As Variant

Wtedy funkcja będzie działać wstecz.

M0nique · słuchacz **Pomógł:** 1 raz Posty: 12

Przepraszam, że dopiero teraz odpisuję.

Funkcja działa tak jak chciałem.

Dziękuję za pomoc!