< návrat zpět
MS Excel
Téma: Hladanie,kopirov-MAKRO 
Zaslal/a pedrosino 7.10.2011 2:22
Ahoj,
potreboval by som pomoct s makrom, ktore by vyhladalo vsetky hodnoty v stlpci napr. B, ktore by sa rovnali hodnote na pozicii A1. Tieto najdene hodnoty zo stlpca B rovnajúce sa hodnote A1 by následne skopirovali do druheho zosita do stlpca A.
A zase by pokracovalo v hladani v stlpci B ale uz s hladanou hodnotou A2 a tieto hodnoty by sa skopirovali do druheho harku do stlpca B, atd.
Ide o to ze hladanie by som ako tak zvladol, ale neviem ako nastavit aby si samo nacitalo hladanu hodnotu z bunky A1, ktoru by hladalo v celom stlpci B a naslo by to ale vsetky zhody nie len presne...a tieto zhody by skopirovalo niekde inde do druheho slpca a pokracovalo by to v hladani ale uz s dalsimi hladanymi hodnotami z buniek A2, A3....
Cize napr. bunka A1 bude obsahovat hodnotu "A"... a cely stlpec B bude naplneny nejakymi hodnotami napr.: "A", "AB", "FF", "HA", "FD", "CA", "AR", "GB", "BF"... a ja chcem aby vsetky hodnoty zo stlpca B, ktore obsahuju v tomto pripade hodnotu bunky A1 cize "A", sa prekopirovali do druheho zosita do stlpca A... cize vo vysledku budu v druhom zosite v stlpci A najdene hodnoty: "A", "AB", "HA", "CA"...
...a dalej ak bude v bunke A2 hodnota "B" tak aby sa tieto hodnoty zase vyhladali a prekopirovali sa do druheho zosita do stlpca B, cize vo vysledku budu v stlpci B v druhom zosite tieto hodnoty: "AB", "GB", "BF"... atd.
Neviem, ci som to dostatocne vysvetlil o co mi ide, ale dufam, ze ano... :)
Poki(7.10.2011 11:46)#006105
co takhle:
Sub hledat()
Dim i As Long
Dim j As Long
Dim S As String
Dim L As String
Dim Vysledek
S = ThisWorkbook.Name
L = ActiveSheet.Name
Workbooks.Add
For i = 1 To Workbooks(S).Worksheets(L).Cells(65000, 1).End(xlUp).Row
For j = 1 To Workbooks(S).Worksheets(L).Cells(65000, 2).End(xlUp).Row
Vysledek = InStr(1, Workbooks(S).Worksheets(L).Cells(j, 2), Workbooks(S).Worksheets(L).Cells(i, 1))
If Vysledek = 0 Then
Else
Workbooks(Workbooks.Count).Worksheets(1).Cells(1, i) = Workbooks(S).Worksheets(L).Cells(i, 1)
Workbooks(Workbooks.Count).Worksheets(1).Cells(Cells(65000, i).End(xlUp).Row + 1, i) = _
Workbooks(S).Worksheets(L).Cells(j, 2)
End If
Next j
Next i
With Workbooks(Workbooks.Count).Worksheets(1).Range(Cells(1, 1), Cells(1, i - 1))
.Font.Bold = True
.HorizontalAlignment = xlCenter
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
End Subcitovatpedrosino(7.10.2011 12:09)#006106 
Dik Poki,
si proste SUPER! presne takto som to potreboval, este raz veeeelka vdaka :)
Este posledna otazocka... dalo by sa aby tie najdene hodnoty hodilo pekne pod seba, ale nie kazdu do novej bunky-noveho riadku, ale aby ich hodilo vsetky len do jednej bunky pod seba?
citovat Poki(7.10.2011 12:14)#006107 No - zrovna nevim, jak bych to udelal (ale urcite by to nebyl problem), ALE to je neco, co bych rozhodne nedoporucoval, protoze se s tim pak uz neda nic delat - navic by zobrazeni bylo podobne.
Preferuji vzdy co zaznam, to bunka, protoze s takovyma informacema se da dal pracovat - to, co zadas je proti jakykoliv logice, takze se o to ani nebudu pokouset
citovatpedrosino(7.10.2011 12:18)#006108 Jasne chapem... :) ide o to ze tie najdene hodnoty uz nebudem viac spracovavat, cize to ze sa s tym uz nebude dat pracovat nevadi... akurat ja si to chcem potom vyimportovat do XML ako jednu premennu a to by mi ulahcilo samotne XML, nebusel by som riesit pridavanie kazdeho riadku v stlpci... ale stacilo by prave ten jeden riadok so vsetkymi hodnotami v bunke...:)
citovat Poki(10.10.2011 9:46)#006131 No tak asi takhle:
Sub hledat()
Dim i As Long
Dim j As Long
Dim S As String
Dim L As String
Dim Vysledek
Dim Obsah As String
S = ThisWorkbook.Name
L = ActiveSheet.Name
Workbooks.Add
For i = 1 To Workbooks(S).Worksheets(L).Cells(65000, 1).End(xlUp).Row
Obsah = ""
For j = 1 To Workbooks(S).Worksheets(L).Cells(65000, 2).End(xlUp).Row
Vysledek = InStr(1, Workbooks(S).Worksheets(L).Cells(j, 2), Workbooks(S).Worksheets(L).Cells(i, 1))
If Vysledek = 0 Then
Else
Workbooks(Workbooks.Count).Worksheets(1).Cells(1, i) = Workbooks(S).Worksheets(L).Cells(i, 1)
Obsah = Obsah & Chr(10) & Workbooks(S).Worksheets(L).Cells(j, 2)
End If
Next j
Obsah = Right(Obsah, Len(Obsah) - 1)
Workbooks(Workbooks.Count).Worksheets(1).Cells(Cells(65000, i).End(xlUp).Row + 1, i) = Obsah
Next i
With Workbooks(Workbooks.Count).Worksheets(1).Range(Cells(1, 1), Cells(1, i - 1))
.Font.Bold = True
.HorizontalAlignment = xlCenter
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
End Subcitovatpedrosino(10.10.2011 11:47)#006136 Je to super, este raz velka vdaka... :)
citovat
RSS nejnovější články