excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: Nahradit nejnižší...
MS Excel
Téma: Nahradit nejnižší... 
Zaslal/a slavekskeeve 26.1.2017 20:00
Ahoj, potřeboval bych poradit s makrem. Mám sloupec A, kde jsou číselné hodnoty, které budou pokaždé jiné (při každém exportu do excelu) a co potřebuju je, aby makro udělalo následující:
1) najde nejnižší číselnou hodnotu (i ve více řádcích) a všechny je přejmenoval např. na "1", potom druhou nejnišží a nahradit "2" atd...Dokud se nenahradí všechno.. Dejme tomu, že mám hodnoty 123, 999 a 321 a potřebuji aby se všechny 123 nahradily jedničkou, všechny 999 trojkou a 321 dvojkou. Jde o sloupec, takže Range A2 až An - díky za pomoc. Hledal jsem, ale.. 
(27.1.2017 0:21)#034720
Pomocou Match predsa urcim poziciu bunky zo stlpca A v zozname z Query table, v ktorej mam unikatne hodnoty uz zotriedene. Inymi slovami, match mi uz urci ziadane poradie hodnoty bunky v stlpci A.. Pisem uz z mobilu, lezim v posteli.
Ten unikatny zoznam z Query table bude druhym argumentom funkcie Match, prvym bude hodnota bunky zo stlpca A..citovat
Ten unikatny zoznam z Query table bude druhym argumentom funkcie Match, prvym bude hodnota bunky zo stlpca A..citovat
(27.1.2017 0:38)#034724
No jo, ale zadavatel chce nahradit všechny výskyty hodnoty jejím pořadím.citovat
Vsak hej.
1. Naimportuje data.
2. Refreshne Query table (refresh uz moze byt sucast Vba scriptu)
3. Vo Vba vyhodnoti cez Match(BunkaVstlpciA,zoznamZqueryTable,0) poradie, to scriptom rovno zapise do BunkaVstlpciA
Predosly prispevok som doplnil, mozno si nepochopil, ako som to myslel s poradim argumentov u Match..citovat
1. Naimportuje data.
2. Refreshne Query table (refresh uz moze byt sucast Vba scriptu)
3. Vo Vba vyhodnoti cez Match(BunkaVstlpciA,zoznamZqueryTable,0) poradie, to scriptom rovno zapise do BunkaVstlpciA
Predosly prispevok som doplnil, mozno si nepochopil, ako som to myslel s poradim argumentov u Match..citovat
Do Replace bych nešel. Tady se nabízí SQL. Bohužel MSQuery totoSELECT
t5.Poradi
FROM
test AS t4
LEFT JOIN
(
SELECT DISTINCT
t3.Hodnota,
(
SELECT
COUNT(t2.Hodnota) + 1
FROM
(
SELECT DISTINCT
t1.Hodnota
FROM
Test AS t1
) AS t2
WHERE
t2.Hodnota < t3.Hodnota
) AS Poradi
FROM
Test AS t3
) AS t5 ON
t4.Hodnota = t5.Hodnotazdá se nezvládá (provedl jsem 1 pokus) a tak jsem to udělal přes ADO.
Výstup jsem si šoupl do jiného listu, ať to vidím.
Nakonec jsem použil Transpose (pokud by bylo více než 65k řádků, muselo by se upravit)Sub subReplace()
Const csSHEET_SOURCE As String = "Zdroj"
Const csSHEET_OUT As String = "Vystup"
Dim adoConn As Object
Set adoConn = CreateObject("ADODB.Connection")
adoConn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Macro;HDR=NO"";"
With adoConn
.Mode = 1
On Error Resume Next
.Open
If Not Err.Number = 0 Then
Debug.Print "001 " & Err.Description
End If
On Error GoTo 0
If adoConn.State = 1 Then
Dim sSql As String
sSql = "SELECT t5.Poradi FROM [" & csSHEET_SOURCE & "$] AS t4 LEFT JOIN (SELECT DISTINCT t3.F1, (SELECT COUNT(t2.F1) + 1 FROM (SELECT DISTINCT t1.F1 FROM [" & csSHEET_SOURCE & "$] AS t1) AS t2 WHERE t2.F1 < t3.F1) AS Poradi FROM [" & csSHEET_SOURCE & "$] AS t3) AS t5 ON t4.F1 = t5.F1"
Dim adoRS As Object
Set adoRS = CreateObject("ADODB.Recordset")
On Error Resume Next
adoRS.Open sSql, adoConn, 3, 1, 1 ' adOpenStatic, adLockReadOnly, adCmdText
If Not Err.Number = 0 Then
Debug.Print "002 " & Err.Description
End If
On Error GoTo 0
If Not adoRS Is Nothing Then
If Not adoRS.ActiveConnection Is Nothing Then
If adoRS.State = 1 Then
If Not adoRS.BOF And Not adoRS.EOF Then
Dim vVals As Variant
vVals = adoRS.GetRows
ThisWorkbook.Sheets(csSHEET_OUT).Cells(1).Resize(UBound(vVals, 2) - LBound(vVals, 2) + 1, 1).Value = Application.Transpose(vVals)
End If
adoRS.Close
Set adoRS = Nothing
End If
End If
End If
.Close
End If
End With 'adoConn
Set adoConn = Nothing
End SubEdit:
Vidím tam potenciální chybu - oproti příloze jsem posunul zápis dat nahoru - v příloze to neměním
t5.Poradi
FROM
test AS t4
LEFT JOIN
(
SELECT DISTINCT
t3.Hodnota,
(
SELECT
COUNT(t2.Hodnota) + 1
FROM
(
SELECT DISTINCT
t1.Hodnota
FROM
Test AS t1
) AS t2
WHERE
t2.Hodnota < t3.Hodnota
) AS Poradi
FROM
Test AS t3
) AS t5 ON
t4.Hodnota = t5.Hodnotazdá se nezvládá (provedl jsem 1 pokus) a tak jsem to udělal přes ADO.
Výstup jsem si šoupl do jiného listu, ať to vidím.
Nakonec jsem použil Transpose (pokud by bylo více než 65k řádků, muselo by se upravit)Sub subReplace()
Const csSHEET_SOURCE As String = "Zdroj"
Const csSHEET_OUT As String = "Vystup"
Dim adoConn As Object
Set adoConn = CreateObject("ADODB.Connection")
adoConn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Macro;HDR=NO"";"
With adoConn
.Mode = 1
On Error Resume Next
.Open
If Not Err.Number = 0 Then
Debug.Print "001 " & Err.Description
End If
On Error GoTo 0
If adoConn.State = 1 Then
Dim sSql As String
sSql = "SELECT t5.Poradi FROM [" & csSHEET_SOURCE & "$] AS t4 LEFT JOIN (SELECT DISTINCT t3.F1, (SELECT COUNT(t2.F1) + 1 FROM (SELECT DISTINCT t1.F1 FROM [" & csSHEET_SOURCE & "$] AS t1) AS t2 WHERE t2.F1 < t3.F1) AS Poradi FROM [" & csSHEET_SOURCE & "$] AS t3) AS t5 ON t4.F1 = t5.F1"
Dim adoRS As Object
Set adoRS = CreateObject("ADODB.Recordset")
On Error Resume Next
adoRS.Open sSql, adoConn, 3, 1, 1 ' adOpenStatic, adLockReadOnly, adCmdText
If Not Err.Number = 0 Then
Debug.Print "002 " & Err.Description
End If
On Error GoTo 0
If Not adoRS Is Nothing Then
If Not adoRS.ActiveConnection Is Nothing Then
If adoRS.State = 1 Then
If Not adoRS.BOF And Not adoRS.EOF Then
Dim vVals As Variant
vVals = adoRS.GetRows
ThisWorkbook.Sheets(csSHEET_OUT).Cells(1).Resize(UBound(vVals, 2) - LBound(vVals, 2) + 1, 1).Value = Application.Transpose(vVals)
End If
adoRS.Close
Set adoRS = Nothing
End If
End If
End If
.Close
End If
End With 'adoConn
Set adoConn = Nothing
End SubEdit:
Vidím tam potenciální chybu - oproti příloze jsem posunul zápis dat nahoru - v příloze to neměním
Příloha: 
34731_zamenporadi.zip (16kB, staženo 21x)
citovat34731_zamenporadi.zip (16kB, staženo 21x)MS Query zvláda toto:
SELECT DISTINCT data
FROM `Sheet1$`
ORDER BY data
Vytvori jednostlpcovu QueryTable, vo vystupe mam unikatne hodnoty. Proti QueryTable cez Match urcim poradie dat v stlpci A: v QueryTable mam hodnoty zotriedene, tzn. za sebou idu hodnoty 123, 321 a 999. Bunka v stlpci A (povedzme A3 ma hodnotu 999). Match(A3,DataZqueryTable,0) vrati 3, a to je hodnota, ktoru zapisem do A3..
Data je nazov stlpca A (bunka A1).citovat
SELECT DISTINCT data
FROM `Sheet1$`
ORDER BY data
Vytvori jednostlpcovu QueryTable, vo vystupe mam unikatne hodnoty. Proti QueryTable cez Match urcim poradie dat v stlpci A: v QueryTable mam hodnoty zotriedene, tzn. za sebou idu hodnoty 123, 321 a 999. Bunka v stlpci A (povedzme A3 ma hodnotu 999). Match(A3,DataZqueryTable,0) vrati 3, a to je hodnota, ktoru zapisem do A3..
Data je nazov stlpca A (bunka A1).citovat
Zajímavá debata. Bohužel nemám moc času.
Napadlo mne, že se řeší jak hodnoty vybrat, setřídit, ..., neřeší samotné číselné hodnoty:
např.: 0, 1, 2 ..
Když všechny 0 nahradím jedničkou, ...citovat
Napadlo mne, že se řeší jak hodnoty vybrat, setřídit, ..., neřeší samotné číselné hodnoty:
např.: 0, 1, 2 ..
Když všechny 0 nahradím jedničkou, ...citovat
@AL
Ano - toto jsi napsal už dříve. Bohužel to vyžaduje zápis na list, pak výpočet a převod na hodnoty. Tedy několikrát používáš zápis na listu. Výsledek dostaneš, takže proti tomu nic nemám.
Já to chtěl všechno mimo a to umí SQL.
další možností je asi použití Dictionary místo Collection, který by snad měl umět řazení (nikdy jsem ho nepoužil, tak pokud plácám, tak mně opravte) - opět mimo zápis na list, ale několik cyklů.
Pokud se chceme vyhnout Evaluate do pole, tak mi nápad s SQL přišel zajímavý a vyzkoušel jsem ho.citovat
Ano - toto jsi napsal už dříve. Bohužel to vyžaduje zápis na list, pak výpočet a převod na hodnoty. Tedy několikrát používáš zápis na listu. Výsledek dostaneš, takže proti tomu nic nemám.
Já to chtěl všechno mimo a to umí SQL.
další možností je asi použití Dictionary místo Collection, který by snad měl umět řazení (nikdy jsem ho nepoužil, tak pokud plácám, tak mně opravte) - opět mimo zápis na list, ale několik cyklů.
Pokud se chceme vyhnout Evaluate do pole, tak mi nápad s SQL přišel zajímavý a vyzkoušel jsem ho.citovat
Karle, mne ale zapis na list nevadi. List schovam, subor bude mat o niekolko kb viac, na riesenie problemu dostatocne. MS query vyuzijem, aby som nemusel pisat spustu riadkov kodu. Krom toho, SQL je na filtrovanie a triedenie rychlejsie, nez VBA. Takze volim jednoduchost, malou danou je par kb na viac a mozno nepatrne pomalsie z dovodu opakovanych zapisov na list, nez cele to poriesit cez arrays a az nasledne zapisat do listu. Zalezi na konkretnej situacii, mnozstve dat a poziadavkoch na rychlost, toto ale asi nema sluzit pre riadenie vesmirnej lode, takze mne staci z pohladu funkcnosti moje riesenie. Ovsem, som rad, ze tu vidim i riesenia od Vas.citovat
@AL
Výsledek dostaneš, takže proti tomu nic nemám.
;))
Ono záleží, jaké má člověk prostředky a jestli je to jednorázovka. Pukud je, má to hromadu záznamů a mám Access, tak to udělám v něm a překopčim de excelu. Je to bez programování (vyjma tedy dotazu).
Pokud to je pár údajů a jednorázovka (viz moje příloha), tak žádný Access ani MSQuery:
Zkopíruji data o pár sloupců vedle, odeberu duplicity, seřadím a použiju MATCH. Tak 30s a mám hotovo.
Dotaz byl na VBA. Mno a protože je to zajímavá úloha (což dokazuje i skladba účastníků diskuse ;)) ), tak jsem to VBA udělal.
Taky jsem se mohl vykašlat na celé SQL a udělat to tak, jak píšu, že ;)) . Ale mne zajímalo to SQL a nelíbí se mi počet přístupů na list.
Sub subReplace()
Cells(1, 3).Resize(Cells(1, 1).CurrentRegion.Rows.Count, 1).Value = Cells(1, 1).CurrentRegion.Value
Cells(1, 3).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
Cells(1, 3).CurrentRegion.Sort Key1:=Cells(1, 3), Order1:=xlAscending, Header:=xlNo
With Cells(1, 1).CurrentRegion
.Offset(0, 1).Formula = "=MATCH(RC[-1]," & Cells(1, 3).CurrentRegion.Address(ReferenceStyle:=xlR1C1) & ",0)"
.Value = .Offset(0, 1).Value
End With 'Cells(1, 1).CurrentRegion
ThisWorkbook.Worksheets("Zdroj").UsedRange.EntireColumn.Offset(0, 1).Delete
End Subcitovat
Výsledek dostaneš, takže proti tomu nic nemám.
;))
Ono záleží, jaké má člověk prostředky a jestli je to jednorázovka. Pukud je, má to hromadu záznamů a mám Access, tak to udělám v něm a překopčim de excelu. Je to bez programování (vyjma tedy dotazu).
Pokud to je pár údajů a jednorázovka (viz moje příloha), tak žádný Access ani MSQuery:
Zkopíruji data o pár sloupců vedle, odeberu duplicity, seřadím a použiju MATCH. Tak 30s a mám hotovo.
Dotaz byl na VBA. Mno a protože je to zajímavá úloha (což dokazuje i skladba účastníků diskuse ;)) ), tak jsem to VBA udělal.
Taky jsem se mohl vykašlat na celé SQL a udělat to tak, jak píšu, že ;)) . Ale mne zajímalo to SQL a nelíbí se mi počet přístupů na list.
Sub subReplace()
Cells(1, 3).Resize(Cells(1, 1).CurrentRegion.Rows.Count, 1).Value = Cells(1, 1).CurrentRegion.Value
Cells(1, 3).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
Cells(1, 3).CurrentRegion.Sort Key1:=Cells(1, 3), Order1:=xlAscending, Header:=xlNo
With Cells(1, 1).CurrentRegion
.Offset(0, 1).Formula = "=MATCH(RC[-1]," & Cells(1, 3).CurrentRegion.Address(ReferenceStyle:=xlR1C1) & ",0)"
.Value = .Offset(0, 1).Value
End With 'Cells(1, 1).CurrentRegion
ThisWorkbook.Worksheets("Zdroj").UsedRange.EntireColumn.Offset(0, 1).Delete
End Subcitovat
Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články