MS Excel

Zdravím,

Potřeboval bych pomoci s makrem.

Upravil jsem makro které hledá hodnoty podle definovaného identifikátoru (najdi hodnotu X a dotáhni k ní hodnotu Y z druhé tabulky)

Toto funguje, nyní bych makro potřeboval rozšířit tak abych mohl zadat těch hodnot X několik desítek, a on je postupně prošel a ke všem vypsal hodnoty Y.

V příloze zasílám makro které toto provede s jednou proměnou. Pokoušel jsem se to vymyslet i pro více X, ale makro zpracuje první hodnotu X, vypíše hodnoty Y a poté skončí a další hodnoty nehledá a nevím jak dál.

Děkuji za pomoc

Zaslat odpověď >

Salsho(15.3.2023 9:53)#054649

-- Mé makro

Sub test()

Dim wsData As Worksheet
Dim wsForm As Worksheet
Dim sFirstFound As String, rList As Range, rLookFor As Range
Dim result As Range, LR As Long
' DEFINOVANI LISTU
Set wsData = ThisWorkbook.Worksheets("data")
Set wsForm = ThisWorkbook.Worksheets("form")
' DEFINOVANI DB JMEN
Set rList = wsData.Range("A1:A" & wsData.Cells(Rows.Count, 1).End(xlUp).Row)
' DEFINOVANI OBLASTI CO HLEDAT
Set rLookFor = wsForm.Range("H2:H150")

' ZJISTENI POSLEDNI POUZITE RADKY VE SLOUPCI "A" V LISTE FORM
LR = wsForm.Range("A" & Rows.Count).End(xlUp).Row
' KDYZ BUDE VETSI NEZ 3, JE TREBA OBLAST VYMAZAT
If LR > 3 Then
wsForm.Range("A4:D" & LR).ClearContents
End If

' VYHLEDANI JMENA V DB JMEN
Set result = rList.Find(rLookFor.Value)

If Not result Is Nothing Then
' POKUD JE JMENO NALEZENO ULOZ POZICI DO RETEZCE
sFirstFound = result.Address
Do
' DEFINOVANI PRVNI VOLNE RADKY V LISTU FORM
LR = wsForm.Range("A" & Rows.Count).End(xlUp).Row + 1
' PRENESENI VYHLEDANYCH DAT NAT POZADOVANOU RADKU
wsForm.Range("A" & LR).Resize(1, 4) = result.Resize(1, 4).Value
' POKRACOVANI HLEDANI DALSIHO VYSKYTU OD POZICE POSLEDNIHO VYSKYTU
Set result = rList.FindNext(result)
' OPAKUJ CYKLUS "DO" DOKUD JE VYRAZ VYHLEDAN A JEHO POZICE JE JINA NEZ PRVNI ULOZENA
Loop While Not result Is Nothing And result.Address <> sFirstFound
End If
End Sub

Příloha: zip

54649_test.zip (22kB, staženo 4x)

citovat

nunus67(15.3.2023 20:26)#054650

zkus tohle:
Option Explicit

Function TransposeArray(MyArray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long, Xlower As Long
Dim Yupper As Long, Ylower As Long
Dim tempArray As Variant
Xupper = UBound(MyArray, 2)
Xlower = LBound(MyArray, 2)
Yupper = UBound(MyArray, 1)
Ylower = LBound(MyArray, 1)
ReDim tempArray(Xlower To Xupper, Ylower To Yupper)
For X = Xlower To Xupper
For Y = Ylower To Yupper
tempArray(X, Y) = MyArray(Y, X)
Next Y
Next X
TransposeArray = tempArray
End Function

Function LastUsedRow(ws As Worksheet, column As String) As Long
LastUsedRow = ws.Cells(ws.Rows.Count, column).End(xlUp).Row
End Function

Sub Search()
Dim shD As Worksheet, shF As Worksheet
Dim arrREF As Variant, arrData As Variant, arrSearch() As Variant, arrResult As Variant
Dim lastR_REF As Long, lastR_Data As Long
Dim iREF As Long, iSearch As Long, iData As Long
Dim strSearch As String

Set shD = ThisWorkbook.Sheets("data")
Set shF = ThisWorkbook.Sheets("form")

lastR_REF = LastUsedRow(shF, "H")
lastR_Data = LastUsedRow(shD, "A")

arrREF = shF.Range("H2:H" & lastR_REF)
arrData = shD.Range("A2:D" & lastR_Data)

For iREF = LBound(arrREF, 1) To UBound(arrREF, 1)
strSearch = CStr(arrREF(iREF, 1))
For iData = LBound(arrData, 1) To UBound(arrData, 1)
If strSearch = CStr(arrData(iData, 1)) Then
iSearch = iSearch + 1
ReDim Preserve arrSearch(1 To 4, 1 To iSearch)
arrSearch(1, iSearch) = arrData(iData, 1)
arrSearch(2, iSearch) = arrData(iData, 2)
arrSearch(3, iSearch) = arrData(iData, 3)
arrSearch(4, iSearch) = arrData(iData, 4)
End If
Next iData
Next iREF

arrResult = TransposeArray(arrSearch)

With shF
.Range("A4").Resize(UBound(arrResult, 1), UBound(arrResult, 2)) = arrResult
End With

End Subcitovat

Salsho(16.3.2023 9:20)#054652

Funguje perfektně, děkuji za pomoc.citovat

Téma: VBA makro vyhledání hodnot

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje