-
GAMEPOD.hu
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
Delila_1
Topikgazda
válasz szőröscica #20520 üzenetére
A kritériumot idézőjelek között add meg, ">35".
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
Topikgazda
válasz szőröscica #20522 üzenetére
Nincs mit.
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
poffsoft
addikt
válasz szőröscica #28660 üzenetére
szia,
ha jól értettem:Sub pasteall()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim PL, files As Variant
Dim i, j As Long
Dim k, l, m, n As Long
Dim wbname As String
Dim rng As Range
Dim rw As Range
Dim cell As Range
' select this workbook and clear all the input sheets
wbname = ThisWorkbook.Name
Workbooks(wbname).Activate
Sheets("Data Sheet").Activate
Range("D4:U1000000").ClearContents
'copy data
For i = 1 To Range("WorkbookCount").Value
workbookpath = Range("Workbook_Name_Header").Offset(i, 0)
PL = Range("Desk_Name_Header").Offset(i, 0)
files = Range("File_Name").Offset(i, 0)
Workbooks.Open (workbookpath)
Sheets("Data").Activate
Range("A65000").Select
Selection.End(xlUp).Select
l = Selection.Row
Range("A2:W" & l).Select
Selection.Copy
Workbooks(wbname).Activate
Sheets("Data Sheet").Activate
Range("A1035000").Select
Selection.End(xlUp).Select
Selection.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues
'Uj resz
Set rng = Selection
For Each rw In rng.Rows
rw.Select
Set cell = Selection.Find(What:="q", After:=Selection(1, 1), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not cell Is Nothing Then
Selection.EntireRow.Delete
Else
Set cell = Selection.Find(What:="d", After:=Selection(1, 1), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not cell Is Nothing Then Selection.EntireRow.Delete
End If
Next
' Uj resz vege
Application.CutCopyMode = False
Workbooks(files).Activate
ActiveWorkbook.Close
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End SubNem teljesen dolgoztam fel, mit is csinál a makród, de ezek a címzések picit bonyolultnak tűnnek a range-k-hez...
[ Szerkesztve ]
[ Szerkesztve ]
-
Delila_1
Topikgazda
válasz szőröscica #28660 üzenetére
Nem kell külön beolvastatni a fájlneveket, majd másolni, végül törölni a felesleges sorokat. Az alábbi makró mindegyik műveletet elvégzi.
Két dolgot kell átírnod benne, az útvonalat, ahonnan a fájlokat behívod, és a kiterjesztést, ha 2007-es verziónál régebbi Excelt használsz.
Sub Osszemasolas()
Dim FN As String, utvonal As String, WS As Worksheet
Dim hova As Long, tabla As Range, CV As Object
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WS = ActiveWorkbook.ActiveSheet
utvonal = "F:\Eadat\Tmp\" 'fájlok útvonala, írd át
FN = Dir(utvonal & "*.xlsx") '2007-es előtti verziónál xls-re írd át
Do While FN <> ""
hova = Application.WorksheetFunction.CountA(Columns(1)) + 1
Workbooks.Open utvonal & FN
Sheets("Data").Select
Range("A1").Select
Set tabla = Cells.CurrentRegion
tabla.Offset(1, 0).Resize(tabla.Rows.Count - 1, tabla.Columns.Count).Copy
WS.Cells(hova, "A").PasteSpecial Paste:=xlPasteAll
Windows(FN).Close False 'Zárja a megnyitott fájlt mentés nélkül
For Each CV In Selection
If CV = "q" Or CV = "r" Then Rows(CV.Row).Delete
Next
FN = Dir()
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Kész", vbInformation
End SubProgramozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
Topikgazda
válasz szőröscica #28660 üzenetére
Kicsit gyorsítva az előbbi (törli a sorokat, ahol bármelyik oszlopban szerepel a q vagy az r):
Sub Osszemasolas()
Dim FN As String, utvonal As String, WS As Worksheet
Dim hova As Long, WF As WorksheetFunction, vege As Long, sor As Long
Dim tabla As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WS = ActiveWorkbook.ActiveSheet
Set WF = Application.WorksheetFunction
utvonal = "F:\Eadat\Tmp\" 'fájlok útvonala, írd át
FN = Dir(utvonal & "*.xlsx") '2007-es előtti verziónál xls-re írd át
Do While FN <> ""
hova = WF.CountA(Columns(1)) + 1
Workbooks.Open utvonal & FN
Sheets("Data").Select
Range("A1").Select
Set tabla = Cells.CurrentRegion
tabla.Offset(1, 0).Resize(tabla.Rows.Count - 1, tabla.Columns.Count).Copy
WS.Cells(hova, "A").PasteSpecial Paste:=xlPasteAll
Windows(FN).Close False 'Zárja a megnyitott fájlt mentés nélkül
vege = WF.CountA(Columns(1))
For sor = hova To vege
If WF.CountIf(Rows(sor), "q") > 0 Or WF.CountIf(Rows(sor), "r") > 0 Then
Rows(sor).Delete shift:=xlUp
End If
Next
FN = Dir()
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Kész", vbInformation
End Sub[ Szerkesztve ]
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Fferi50
őstag
válasz szőröscica #31383 üzenetére
Szia!
"Autofilter makrót írok, és azt szeretném megoldani, hogy 37 dologra szűrjön rá"
Én a helyedben inkább az AdvancedFilter metódust használnám. Itt összeállíthatsz egy szűrőtartományt - ahová akár kézzel, akár makróval beírhatod a feltételeket, eldöntheted, hogy helyben szűrjön, vagy átmásolja egy másik helyre.
Szerintem nézd meg ezt a lehetőséget - makró rögzítéssel megkaphatod az alapot hozzá.Üdv.
-
Jhonny06
veterán
válasz szőröscica #31421 üzenetére
Igen, ott próbáltam először, de sehogy nem megy, még így se: ####.##
Csak ha kézzel átírom. Itt valami beállítások nagyon összeakadhatnak, más OS szinten is átírtam a regionális beállításoknál, és még úgy se.
-
SzlobiG
félisten
válasz szőröscica #31419 üzenetére
Nem jó sajna.
A "b" oszlop végén kell a műszakokat szummàzni,mert a többi oszlopban adatok vannak.
Valahogy ìgy:
A oszlop B oszlop
2016.01.01 délelőtt
2016.01.01 délelőtt
2016.01.01 délelőtt
2016.01.01 délutàn
2016.01.01 délutàn
2016.01.02 éjszaka
2016.01.02 éjszaka
A oszlop B oszlop
Műszak összesen: 3Meglehet ezt oldani?
-
Fferi50
őstag
válasz szőröscica #33445 üzenetére
Szia!
Az egyik lehetőség, hogy hibakezelést építesz be: On Error Resume Next sorral.
Ha tudod, hogy csak ez lehet a hiba, akkor semmit nem is kell tenned, csak a programszekció végén visszaadni a hibakezelést a VBA-nak: On Error Goto 0
Ez azért szerintem kissé kockázatos, bár természetesen minden sor után meg lehet nézni, milyen hiba keletkezett (If ERR= x akkor mi legyen - a hibaszámokat megtalálod a helpben).Másik megoldás, hogy végigmész a tételeken:
Dim pvti as PivotItem
For Each pvti in ,PivotItems
If pvti.Name = "Level 2" Or pvti.Name = "Level 1" Or pvti.Name = "Level 3" Then pvti.Visible = True
NextNekem ez utóbbi jobban tetszik.
Üdv.
-
Fferi50
őstag
válasz szőröscica #34137 üzenetére
Szia!
Szerintem a legutolsó PasteSpecial után nem mész vissza a forrás munkalapra, hanem a cél munkalapon maradsz, ezért ott vizsgálja a következő "D" oszlopbeli cellát, aminek nagy eséllyel nincs értéke.
Tehát hiányzik egy
Sheets("Trading activity_NEW").Select
sor az End If elé.
Egyébként a rengeteg select teljesen elhagyható, de ezt most másra bízom.Üdv.
[ Szerkesztve ]
-
poffsoft
addikt
válasz szőröscica #34140 üzenetére
Option Explicit
Public Sub makro1()
Dim i As Integer
Dim l As Integer
Dim RowCount As Integer
Dim S1 As String
Dim S2 As String
RowCount = 10
S1 = "Submitter excl. trades"
S2 = "Trading activity_NEW"
Worksheets(S1).Select
For i = 3 To RowCount
If Not IsEmpty(Range("D" & i)) Then
l = Range("H" & Rows.Count).End(xlUp).Row + 1
Range("H" & l) = Range("J" & i)
Range("I" & l) = Sheets(S2).Range("D" & i)
End If
Next i
End Sub[ Szerkesztve ]
[ Szerkesztve ]
-
Fferi50
őstag
válasz szőröscica #37105 üzenetére
Szia!
Hova vannak elmentve a makróid? Modulba, munkalap kódlapjára, Thisworkbook kódlapjára?
Üdv.
-
sztanozs
veterán
válasz szőröscica #42427 üzenetére
1) nem látom, hogy a boundary definiálva lenne
2) nem xml adat amit átadsz (nem beszédes a változónév)
3) nincsenek definiálva a változók
Nem bonyolítod el ezt egy kicsit?Én így küldök GET/POST ützenetet:
Public Function CMD_ServiceXML(ByRef Vars As Variant, Query As String, Optional Method As String = "GET") As Object
Dim strResponse As String
Dim objHTTP As Object
Set objHTTP = CreateObject("Microsoft.XMLHTTP")
If IsArray(Vars) Then
Dim var, vx
vx = 0
For Each var In Vars
Query = Replace(Query, "{" & vx & "}", URLEncode(CStr(var)))
vx = vx + 1
Next
Else
Query = Replace(Query, "{0}", UCase(Vars))
End If
If UCase(Method) = "GET" Then
objHTTP.Open "GET", Query, False
objHTTP.Send
ElseIf UCase(Method) = "POST" Then
Dim URI
URI = Split(Query, "?")
objHTTP.Open "GET", URI(0), False
objHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objHTTP.Send URI(1)
Else
Set CMD_ServiceXML = Nothing
End If
If objHTTP.statusText = "OK" Then
strResponse = objHTTP.ResponseText
Set objHTTP = Nothing
Else
Set CMD_ServiceXML = Nothing
Set objHTTP = Nothing
Exit Function
End If
Set CMD_ServiceXML = CreateObject("Msxml2.DOMDocument.3.0") ''// Using MSXML 3.0
On Error Resume Next
CMD_ServiceXML.LoadXML strResponse
If err Then
Debug.Print "<CMD XML>", Vars, strResponse
err.Clear
Set CMD_ServiceXML = Nothing
End If
On Error GoTo 0
End Function[ Szerkesztve ]
JOGI NYILATKOZAT: A bejegyzéseim és hozzászólásaim a személyes véleményemet tükrözik; ezek nem tekinthetők a munkáltatóm hivatalos állásfoglalásának...
-
sztanozs
veterán
válasz szőröscica #42433 üzenetére
Bár nem szorosan a témához tartozik, de célszerű minden változót lokálisan kezelni és ha kell, a függvénynek átadni. A másik pedig az
Option Explicit
használata. Ez megakadályozza a definiálatlan változók használatát, ami szintén gyakori problémaforrás.Szvsz egyébként az lehet a gond (nem látom a konkrét lekérést), hogy az
MSXML2.XMLHTTP
nem kezeli jól a certificate hibákat és az adott gép valamiért nem tudja leellenőrizni az oldal tanúsítványát.
Célszerű leellenőrizni a certificate store-t a gépen, vagyMSXML2.XMLHTTP
helyettMsxml2.ServerXMLHTTP.6.0
-t használni (ezzel viszont neked kell feldolgoznod a header-t és kezelni a cookie-kat): [link]JOGI NYILATKOZAT: A bejegyzéseim és hozzászólásaim a személyes véleményemet tükrözik; ezek nem tekinthetők a munkáltatóm hivatalos állásfoglalásának...
-
sztanozs
veterán
válasz szőröscica #42441 üzenetére
Próbáld meg az adott gépen IE-ben megnyitni a linket, és ha nem nyílik, vagy cert hiba van, akkor látni fogod.
JOGI NYILATKOZAT: A bejegyzéseim és hozzászólásaim a személyes véleményemet tükrözik; ezek nem tekinthetők a munkáltatóm hivatalos állásfoglalásának...
-
sztanozs
veterán
válasz szőröscica #42451 üzenetére
Ami ebben a sorban előáll az URL paraméterben, amikor a hibát kapod:
.Open "POST", URL, False
JOGI NYILATKOZAT: A bejegyzéseim és hozzászólásaim a személyes véleményemet tükrözik; ezek nem tekinthetők a munkáltatóm hivatalos állásfoglalásának...
-
Fferi50
őstag
válasz szőröscica #43337 üzenetére
Szia!
Úgy néz ki, hogy megváltoztak a használható tulajdonságok.
[link] Itt megtalálhatod a hozzá tartozó helpet.
Az Application.Version függvényében hajtathatod végre a kódot egyik v. másik Excelben.
Az Excel 2016 verziója 16.0Üdv.
[ Szerkesztve ]
Új hozzászólás Aktív témák
- World of Warcraft Shadowlands Collectors edition EU EN
- Canva Pro előfizetés - 1 éves
- Bitdefender Total Security 3év/3eszköz! - "Tökéletes védelem most kedvező áron..."
- Microsoft licencek KIVÉTELES ÁRON AZONNAL - UTALÁSSAL IS AUTOMATIKUS KÉZBESÍTÉS - Windows és Office
- Warhammer Online - Age of Reckoning (DE) Collectors Box (Figurával!)
Állásajánlatok
Cég: Promenade Publishing House Kft.
Város: Budapest
Cég: Ozeki Kft.
Város: Debrecen