Makro v Excelu pro spojení dvou tabulek


Jedna z věcí, kterou na excelu nemám rád je spojování dvou tabulek podle klíče (nelze udělat automaticky). Prakticky lze pouze pro tento účel využít vestavěnou fci excelu SVYHLEDAT(..), která spáruje a zobrazí jeden sloupec ze zdrojové tabulky. Druhou možností je vytvořit jednoduché makro B) .

Vytvořil jsem tedy makro SpojTabulky, které spojí dvě tabulky dle prvního sloupce, resp. připojí zdrojovou tabulku, kdy budou zachovány všechny prvky v ”cílové” tabulce a v případě shody se připojí prvky ze ”zdrojové” tabulky.

Uvažujeme následující vstupní data (viz obrázek). Přejeme si :) spojit tabulku přesčasů s tabulkou zaměstnanců, kdy spojovacím prvkem je os. číslo zaměstnance. Následně tedy připojíme jméno a přijmení zaměstnance k tabulce přesčasů (ale zachováme datum a délku přesčasu).

Další obrázek zobrazuje spojovací prvek – klíč.

A teď jak to funguje:

  1. Vybereme zdrojové prvky, které budou v případě shody doplněny (spuštěním makra).
  1. Vybereme / označíme cílovou tabulku, s tím, že za poslední označený sloupec se v případě shody klíče zkopírují hodnoty ze zdrojové tabulky vyjma prvního (klíčového) sloupce.
  1. A nyní se již můžeme kochat výsledkem B)

Tip: pokud se shoduje název klíčového sloupce zkopírují se i názvy sloupců.

A nyní již příslušná makra:

  • RangeDataType je pomocné makro pro výběr hodnot.
  • SpojTabulky
náhled zdrojového kódu
Sub SpojTabulky()
 
 Dim pOblast As Range
 Dim hVysledek As Range
 Dim cOblas As Range
 Dim chyba As Boolean
 
 'vstupní pole
 Set pOblast = RangeDataType("Vyberte oblast", "Zdroj")
 Set cOblast = RangeDataType("Vyberte oblast", "Cíl")
 
 If pOblast Is Nothing Then
  MsgBox "CHYBA: špatně zadané zdrojové pole párované oblasti!"
  chyba = True
 End If
 
 If cOblast Is Nothing Then
  MsgBox "CHYBA: špatně zadaná cílová oblast!"
  chyba = True
 End If
 
 If chyba = True Then
   Exit Sub
 End If
 
 For radek = 1 To cOblast.Rows.Count
 
  'změním oblast hledání pouze na jeden sloupec = id a následně vyhledávám id
  Set hVysledek = pOblast.Resize(pOblast.Rows.Count, 1).Find(what:=cOblast.Cells(radek, 1), LookAt:=xlWhole)
 
  'jestliže najdu nějaké id, zkopíruji oblast
If Not hVysledek Is Nothing Then
      hVysledek.Offset(0, 1).Resize(, pOblast.Columns.Count - 1).Copy _
       Destination:=Sheets(cOblast.Parent.Name).Range(cOblast.Cells(1, 1).Address).Offset(radek - 1, cOblast.Columns.Count)
End If
 
 Next radek
 
 Sheets(cOblast.Parent.Name).Activate
 
End Sub
 
Function RangeDataType(Title As String, Prompt As String) As Range
 
Dim rRange As Range
 
On Error Resume Next
  Application.DisplayAlerts = False
 
  Set rRange = Application.InputBox(Prompt:=Prompt, Title:=Title, Type:=8)
 
 On Error GoTo 0
  Application.DisplayAlerts = True
 
   If rRange Is Nothing Then
    Exit Function
   Else
    Set RangeDataType = rRange
   End If
 
End Function

Nebo lze použít hotový doplněk nastroje.xlam, který lze spustit nebo přidat do adresáře Doplňky nebo XLSTART např. (X:\Users\zmt\Ap­pData\Roaming\Mi­crosoft\Excel\XLSTAR­T) pro automatické spuštění při startu excelu.

8 komentářů


před čtyřmi lety
reagovat
SUPER
Petr
před čtyřmi lety
reagovat
Ahoj, makro je super.

Snažil jsem se to uložit jako doplněk, což se ještě podařilo, ale při spuštění a vybrání oblastí to nakonec výsledek neudělá. Nevím zda dělám někde chybu, ale už si nevím rady. Nebylo by možné dostat to už jako doplněk od tebe?

Případně poradit jak na to.

Díky moc
zmt
před čtyřmi lety
reagovat
Ahoj,

přidal jsem doplněk ke stáhnutí \:\)
Petr
před čtyřmi lety
reagovat
Super!

Jen škoda, že se mi k cílové části napřidají i názvy sloupců ze zdrojové části. Ale to je detail ;\)
zmt
před čtyřmi lety
reagovat
Viz tip: pokud se shoduje název klíčového sloupce zkopírují se i názvy sloupců. ;\)
hoj
před třemi lety
reagovat
Ahoj, nebo to jde ještě jednodušeji přes SQL v excelu spojením tabulek. http\://superuser.com/questions/420635/how-do-i-join-two-worksheets-in-excel-as-i-would-in-sql
zmt
před třemi lety
reagovat
Právě, že jednodušeji (na pár kliknutí) to nejde. Proto jsem si vytvořil toto makro ;\)
Tom
před třemi lety
reagovat
autorovi velké Díky!

Přidejte komentář

Text komentáře musí být zadán, ostatní údaje nejsou povinné. HTML tagy nejsou povoleny.

Captcha picture.