Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Rozbicie i przeniesienie danych

posampas · Exceloholic Wersja: Win Office 2007 Posty: 196

Witam ponownie po długiej przerwie.

Z racji na potrzebę rozbudowy narzędzia, które powstało przy ogromnej Waszej pomocy, znów muszę się do Was o nią zwrócić.

Obecny kod rozbija mi np. kod PPK16-800x2000 na 3 elementy do kolumn N,O,P.
Niestety w międzyczasie powstał kolejny człon tego kodu, gdzie jego postać może wyglądać np. PPK16-800x2000-R16, i ten ostatni człon (R16) jeśli wystąpi (zawsze po „-”) chciałbym wyciągnąć dodatkowo do kolumny AA.

Druga część już jest bardziej skomplikowana.

W kolumnie L pojawia się tylko pierwszy człon kodu (np. PP16). Jego warianty ujęte są w kolumnie M. Może występować jeden wariant lub więcej. Jeśli jest ich więcej, to zawsze rozdzielane są znakiem „|”. Cyfra lub liczba przed „_” jest ilością tego wariantu.

* Chciałbym, aby w takim przypadku, suma z kolumny J (tylko dla tych wariantów) pojawiła się w komórce AA1.
*Warianty z kolumny M zostały rozdzielone wg „|” do kolejnych wierszy (zastępując ten pierwszy człon kodu w kolumnie L) przy powieleniu danych tego klienta w tych wierszach. *Cyfra/liczba na początku wariantu (zawsze przed „_”) powinna zastąpić liczbę/cyfrę w kolumnie J.

Dla przykładu: warianty z M11 powinny zostać rozbite na komórkę L11 w postaci PPK16-596x996-R26 i komórkę L12 w postaci PPK16-600X1200 (dodając wiersz) a dane klienta z wiersza 11 powielone do wiersza 12. Natomiast w kolumnie J11 powinna pojawić się liczba z pierwszego wariantu (przed ”_”) i adekwatnie w J12 liczba z drugiego wariantu (przed „_”).

Mam nadzieję, że nie skomplikowałem zbytnio ;)

Dla zobrazowania problemu załączam przykład.
Pozdrawiam

Test1.xlsm

Pobierz Plik ściągnięto 16 raz(y) 26.82 KB

master_mix · Wysłany: 11-01-2023, 13:16

wystarczy że użyjesz funkcji z wątku
LINK
a jako separator podasz "-" i "X"

posampas · Exceloholic Wersja: Win Office 2007 Posty: 196

Dzięki za radę ;-)

. Spróbuję coś z niego wyciągnąć ;-)

Mimo wszystko wolałbym jednak rozbudowywać już posiadany kod, ponieważ jest powiązany z wieloma pobocznymi elementami mojego projektu.

posampas · Exceloholic Wersja: Win Office 2007 Posty: 196

Witam zacni Panowie i Panie :-)

.
Udało mi się znaleźć makro, które po kilku modyfikacjach odpowiada jednej z moich potrzeb. I tu potrzebuję Waszej pomocy, ponieważ utknąłem na 2 rzeczach.
Pierwsza to taka, że trzeba ręcznie wskazać zakres komórek kolumny M, który chciałbym rozbić do kolejnych wierszy a chciałbym aby tego nie trzeba było ręcznie robić.
I druga to taka, że gdy pojedynczo wskazuję komórki, to kod działa prawidłowo, dodając kolejne wiersze. Lecz gdy wskazuję cały zakres, to nadpisuje mi już istniejące.
Byłby ktoś z Was w stanie rzucić okiem i choć nakierować na rozwiązanie?
Poniżej załączam kod i przykładowe dane w pliku:

Kod:

Public Sub Rozbij_na_wiersze()
Dim xSRg, xIptRg, xCrRg, xRg As Range
Dim xSplitChar As String
Dim xArr As Variant
Dim xFNum, xFFNum, xRow, xColumn, xNum As Integer
Dim xWSh As Worksheet
Set xSRg = Application.InputBox("Wskarz zakres:", "..", , , , , , 8)
If xSRg Is Nothing Then Exit Sub
'xSplitChar = Application.InputBox("Wskarz separator:", "..", , , , , , 2)
xSplitChar = "|"
If xSplitChar = "" Then Exit Sub

Application.ScreenUpdating = False
xRow = xSRg.Row
xColumn = xSRg.Column
Set xWSh = xSRg.Worksheet
For xFNum = xSRg.Rows.Count To 1 Step -1

Set xRg = xWSh.Cells.Item(xRow + xFNum - 1, xColumn)
Debug.Print xRg.Address
xArr = Split(xRg, xSplitChar)

For xFFNum = LBound(xArr) To UBound(xArr)
xRg.EntireRow.Copy
xRg.Offset(1, 0).EntireRow.Insert Shift:=xlShiftDown
xRg.Worksheet.Cells(xRow + xFNum, xColumn) = xArr(xFFNum)
Next
xRg.EntireRow.Delete
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Test1_1.xlsm

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

Kaper · Wysłany: 18-01-2023, 10:14

Czyli może niech procedura z założenia przegląda dane od M2 do ostatniego niepustej komórki w M.
Nadpisywanie występowało wg mnie, gdy próbowałeś zrealizować dzielenie komórki bez separatora.
Tylko te dwie zmiany wprowadziłem do Twojego kodu. Skoro jest Twój i działa, to go uszanujmy :-)

I trzy uwagi o zmiennych:
* Przejrzyj, czy wszystkie deklarowane zmienne są wykorzystywane. Niewykorzystane lepiej usunąć.
* Deklaracja w formie, której używałeś:

Kod:

dim nazwa, nazwa2, nazwa3 as typ

nadaje typ tylko ostatniej zmiennej, nazwa i nazwa 2 są typu Variant. (właściwie to ta i kolejna uwaga zaowocowały jednak trzecią i czwartą zmianą w Twoim kodzie :tak

)
* Nie wiem jak duże są prawdziwe pliki, ale na wszelki wypadek zwykle lepiej zmienne opisujące położenie komórki w arkuszu deklarować jako Long, a nie zwykły Integer

Kod:

Public Sub Rozbij_na_wiersze()
Dim xSRg As Range, xIptRg As Range, xCrRg As Range, xRg As Range
Dim xSplitChar As String
Dim xArr As Variant
Dim xFNum As Long, xFFNum As Long, xRow As Long, xColumn As Long, xNum As Long
Dim xWSh As Worksheet

xSplitChar = "|"
With Sheets("Dane")
Set xSRg = Range(.Cells(2, "M"), .Cells(.Rows.Count, "M").End(xlUp)) 'zakres od drugiego wiersza do najniższej niepustej
End With
Application.ScreenUpdating = False
xRow = xSRg.Row
xColumn = xSRg.Column
Set xWSh = xSRg.Worksheet
For xFNum = xSRg.Rows.Count To 1 Step -1

Set xRg = xWSh.Cells.Item(xRow + xFNum - 1, xColumn)
Debug.Print xRg.Address
If InStr(xRg.Text, xSplitChar) > 0 Then 'wykonaj poniższe działania tylko jeśli w komórce jest separator
xArr = Split(xRg, xSplitChar)

For xFFNum = LBound(xArr) To UBound(xArr)
xRg.EntireRow.Copy
xRg.Offset(1, 0).EntireRow.Insert Shift:=xlShiftDown
xRg.Worksheet.Cells(xRow + xFNum, xColumn) = xArr(xFFNum)
Next
xRg.EntireRow.Delete
End If ' o, do tego miejsca
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

posampas · Exceloholic Wersja: Win Office 2007 Posty: 196

Kaper właśnie o to mi chodziło. Dzięki za wszelkie sugestie. Przejrzę pozostałe kody w projekcie pod kątem Twoich uwag co może pozwoli choć trochę zoptymalizować ich wykonywanie.
Dzięki za szybką reakcję.

posampas · Exceloholic Wersja: Win Office 2007 Posty: 196

Jednak potrzebuję jeszcze Waszej pomocy, bo utknąłem w miejscu.
Rozbijam dane z kolumn L i M na pojedyncze składowe (wg separatorów "-" i "x") i o ile kolumna L rozbija się prawidłowo o tyle kolumna M już nie. Pojawia się tu dodatkowy separator "_". Kombinuje już na różne sposoby i nic, stąd też prośba o Waszą pomoc.
Plik w załączniku

P.S. Do rozbicia każdej z kolumn wykorzystuję 2 razy to samo makro, więc może podpowiecie jak je przy okazji zoptymalizować do jednej spójnej operacji.

Z góry dzięki za pomoc

Testt.xlsb

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

posampas · Exceloholic Wersja: Win Office 2007 Posty: 196

Witam.
Nie mogę przeskoczyć problemu z poprzedniego wpisu. Pomóżcie proszę rozbić dane z kolumny M w postaci np.
1_PPK16-590X510-R5
5_PPK16-600X1200
2_PPK33-950R
na kolejne kolumny rozdzielając je w kolejności separatorów "_", "-","X","-".
Póki co pracuję na kodzie, który rozbija mi dane po separatorach "-","X","-" ale muszę dołączyć na początku separator "_".

Kod:

Sub Podziel_kolumne_M()
Dim pw As Long, ow As Long, i As Long, res
Dim f, g, h, g0 As Long, g1 As Long, g2 As Long, s As String
Dim ErrMsg As String, ErrFlag As Boolean, Len0 As Long
'ErrMsg = "Błędne kody towarów w wierszach:" & vbLf & vbLf
'Len0 = Len(ErrMsg)
On Error GoTo blad
With Worksheets("Dane")
ActiveSheet.Range("L2", ActiveSheet.Range("L2").End(xlDown)).Select
Selection.Replace What:="PPKK", Replacement:="PPK"
Selection.Replace What:="R1", Replacement:="R"
pw = 2
ow = .Cells(.Rows.Count, "M").End(xlUp).Row
For i = pw To ow
s = .Cells(i, "M").Value
If Len(s) > 0 Then
res = Application.VLookup(s, Sheets("Kody").Range("A:B"), 2, 0)
If Not IsError(res) Then
.Cells(i, "S") = res
Else
ErrFlag = True
f = Split(s, "-")
If Right(f(1), 1) = "R" Then f(1) = Replace(f(1), "R", "x1")
g = Split(LCase(f(1)), "x")

If UBound(g) <> 1 Then Err.Raise 1
g0 = g(0)
g1 = g(1)
.Cells(i, "N").Resize(, 4).Value = Array(f(0), , g0, g1)
h = Split(f(2), "-")
.Cells(i, "N").Resize(, 5).Value = Array(f(0), , g0, g1, f(2))

ErrFlag = False
End If
End If
blad:
If ErrFlag Then
'ErrMsg = ErrMsg & i & vbTab & s & vbLf
'.Cells(i, "L").Interior.Color = vbRed
ErrFlag = False
Resume nast
End If
nast:
Next i
End With
If Len(ErrMsg) > Len0 Then MsgBox ErrMsg
End Sub

Dla pewności załączam ponownie plik

Testt.xlsb

Pobierz Plik ściągnięto 4 raz(y) 247.78 KB

Tajan · **Pomógł:** 5234 razy Posty: 11412

Tak spróbuj:

Kod:

Sub Podziel_kolumne_M()
Dim pw As Long, ow As Long, i As Long, res
Dim f, g, h, g0 As Long, g1 As Long, g2 As Long, s As String
Dim ErrMsg As String, ErrFlag As Boolean, Len0 As Long
Dim s0
'ErrMsg = "Błędne kody towarów w wierszach:" & vbLf & vbLf
'Len0 = Len(ErrMsg)
On Error GoTo blad
With Worksheets("Dane")
ActiveSheet.Range("L2", ActiveSheet.Range("L2").End(xlDown)).Select
Selection.Replace What:="PPKK", Replacement:="PPK"
Selection.Replace What:="R1", Replacement:="R"
pw = 2
ow = .Cells(.Rows.Count, "M").End(xlUp).Row
For i = pw To ow
s = .Cells(i, "M").Value
If Len(s) > 0 Then
res = Application.VLookup(s, Sheets("Kody").Range("A:B"), 2, 0)
If Not IsError(res) Then
.Cells(i, "S") = res
Else
ErrFlag = True
If InStr(s, "_") > 0 Then
s0 = Split(s, "_")
s = s0(1): s0 = s0(0)
Else
s0 = ""
End If
f = Split(s, "-")
If Right(f(1), 1) = "R" Then f(1) = Replace(f(1), "R", "x1")
g = Split(LCase(f(1)), "x")

If UBound(g) <> 1 Then Err.Raise 1
g0 = g(0)
g1 = g(1)
.Cells(i, "N").Resize(, 5).Value = Array(s0, f(0), , g0, g1)
h = Split(f(2), "-")
.Cells(i, "N").Resize(, 6).Value = Array(s0, f(0), , g0, g1, f(2))

ErrFlag = False
End If
End If
blad:
If ErrFlag Then
'ErrMsg = ErrMsg & i & vbTab & s & vbLf
'.Cells(i, "L").Interior.Color = vbRed
ErrFlag = False
Resume nast
End If
nast:
Next i
End With
If Len(ErrMsg) > Len0 Then MsgBox ErrMsg
End Sub

posampas · Exceloholic Wersja: Win Office 2007 Posty: 196

Dzięki Tajan. Właśnie o to chodziło.