- Vélemény: nem úgy tűnik, de Lip-Bu Tan most menti meg az Intelt
- HiFi műszaki szemmel - sztereó hangrendszerek
- NVIDIA GeForce RTX 5080 / 5090 (GB203 / 202)
- Fejhallgató erősítő és DAC topik
- Milyen videókártyát?
- Steam Deck
- Ventilátorok - Ház, CPU (borda, radiátor), VGA
- Házimozi haladó szinten
- Mikrokontrollerek Arduino környezetben (programozás, építés, tippek)
- Milyen TV-t vegyek?
-
PROHARDVER!
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
veterán
válasz
Sziszmisz
#16556
üzenetére
Nem biztos, hogy jól értem a feladatot, mert elég rossz példát adtál meg a csatolt képen.
Jobb lett volna, ha a címsor Alma, Kék, Jobb, Egyéb, ill. Körte, Piros, Bal, Egyéb. A képen az O:R tartomány minden tételnél azonos.
Gondolom, a sorok O:R tartományában azt kell feltüntetni, hogy az egyes tételek melyik címsor alá tartoznak. A lenti makró ezt oldja meg.Sub Katalogus()
Dim sor As Integer, usor As Integer, sor1 As Integer
usor = Cells(Rows.Count, "A").End(xlUp).Row
For sor = usor To 1 Step -1
If Cells(sor, "A") = "" Then GoTo Tovabb
If Cells(sor, "A") = "+" Then
sor1 = sor
Do While Cells(sor1, "A") = "+"
sor1 = sor1 - 1
Loop
Cells(sor, "O") = Cells(sor1, "A")
Cells(sor, "P") = Cells(sor1, "B")
Cells(sor, "Q") = Cells(sor1, "C")
Cells(sor, "R") = Cells(sor1, "D")
End If
Tovabb:
Next
End Sub -
Oly
őstag
válasz
Delila_1
#16426
üzenetére
Szia
A valóságban külön sheeteken vannak a táblák és a problémát az okozza, hogy minden költéshez van egy megjegyzés oszlop is, melyet a pivot nem tud betenni.
Így a Te makrós megoldásod hegeszthetem, de az összegző táblán elakadtam.Úgy akarom megcsinálni, hogy A1 cellába beírom a kívánt dátumot és akkor kilistázza, hogy adott napon kik mennyit költöttek az adott boltban (én mellé kiírja nekem a megjegyzést is, ezért nem jó a pivot)
Szóval, hogy tudom neki megadni, hogy rakja be új sorba az emberkét, ha nincs a listában?
Próbálkoztam, hogy beraktam egy ONERROR-t és akkor tegye be a változót egy új sorba, de valamiért folyton hibára fut:Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim sor%, usor%, sorB%, oszlopB%, WF As WorksheetFunction
Dim nev$, uzlet$
Set WF = Application.WorksheetFunction
usor% = Sheets("data").Cells(Rows.Count, "A").End(xlUp).Row
uszem% = Cells(Rows.Count, "A").End(xlUp).Row
Range("b2:u60") = ""
For sor% = 2 To usor%
If Sheets("data").Cells(sor%, 1) >= Range("a1") Then
nev$ = Sheets("data").Cells(sor%, 2)
uzlet$ = Sheets("data").Cells(sor%, 3)
On Error GoTo makesor
sorB% = WF.Match(nev$, Columns(1), 0)
GoTo vansor
makesor:
MsgBox "Hozzuk létre? " & nev$
Cells(uszem% + 1, 1) = nev$
sorB% = WF.Match(nev$, Columns(1), 0)
vansor:
oszlopB% = WF.Match(uzlet$, Rows(1), 0)
Cells(sorB%, oszlopB%) = Sheets("data").Cells(sor%, 4)
Cells(sorB%, oszlopB% + 1) = Sheets("data").Cells(sor%, 5)
End If
Next
End If
End Sub -
csferke
senior tag
válasz
Delila_1
#15958
üzenetére
Delila!
Köszi a gyors választ/megoldást.
Sub Novel_F_et()
Dim sor As Integer, CV As Object
For Each CV In [B27:B38]
If CV <> "" And IsNumeric(CV) Then
On Error GoTo Kov
sor = Application.WorksheetFunction.Match(CV, Sheets(2).Columns(1), 0)
Sheets(2).Cells(sor, "F") = Sheets(2).Cells(sor, "F") + Cells(CV.Row, "F")
End If
Kov:
Next
End SubMivel a B27:B38-ban nem szám van hanem egy-egy termékhez tartozó kód (betűkből és számokból) sz.tem az if ágban nem kell az IsNumeric(CV).??
Nem értem, hogy mi szükség van az On Error GoTo Kov és a Kov: sorokra -
Delila_1
veterán
válasz
csferke
#15952
üzenetére
Sub Datum_L_be()
Dim sor As Integer
sor = Application.WorksheetFunction.Match([A1], Sheets(2).Columns(2), 0)
Sheets(2).Cells(sor, "L") = Date
End SubSub Novel_F_et()
Dim sor As Integer, CV As Object
For Each CV In [B27:B38]
If CV <> "" And IsNumeric(CV) Then
On Error GoTo Kov
sor = Application.WorksheetFunction.Match(CV, Sheets(2).Columns(1), 0)
Sheets(2).Cells(sor, "F") = Sheets(2).Cells(sor, "F") + Cells(CV.Row, "F")
End If
Kov:
Next
End Sub -
#15846
poffsoft
veterán
dellfanboy
#15844
poffsoft
veterán
válasz
dellfanboy
#15844
üzenetére
És a KM állás sorában nincsen olyan cella, ami azonosítja, hogy ez a km állás sora lesz? mert azt akár fv-nyel is megoldhatnánk...
makróval simán átmásolható:
Option Explicit
Sub CopyRows()
Dim i As Integer
Dim r1, c1, r2, c2, r3 As Double
Dim wsTest As Worksheet
Dim sname As String
sname = "Summa"
Set wsTest = Nothing
On Error Resume Next
Set wsTest = Worksheets(sname)
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add(Before:=Sheets(1), Count:=1, Type:=xlWorksheet).Name = sname
End If
Worksheets(sname).Cells.Clear
For i = 1 To Sheets.Count
If Not Worksheets(i).Name = sname Then
r1 = Worksheets(i).UsedRange.Row
c1 = Worksheets(i).UsedRange.Column
r2 = r1 + Worksheets(i).UsedRange.Rows.Count - 1
c2 = c1 + Worksheets(i).UsedRange.Columns.Count - 1
r3 = Worksheets(sname).UsedRange.Row + Worksheets(sname).UsedRange.Rows.Count
Worksheets(i).Select
Worksheets(i).Range(Cells(r1, c1), Cells(r2, c2)).Copy _
Destination:=Worksheets(sname).Cells(r3, c1)
End If
Next i
Worksheets(sname).Select
[A1].Select
End Sub -
-
#15082
Fire/SOUL/CD
félisten
Attas
#15081
-
Attas
aktív tag
Sziasztok. Az utóbbi napok segítségeit utólag is nagyon köszönöm. Még egy kérdés felmerült bennem. Excel makróban is biztos van goto parancs. Hogy kell ezt alkalmazkodik? Van egy if-else macróm amiben azt szeretném, ha teljesül az if feltétel, akkor ne folytassa az END IFA utánküldés utasítások egy részeg, hanem ugorjon a közepére ahova Én utasítom.Megoldható ez? Köszönöm előre is!
-
lappy
őstag
Sub CallMailer()
Dim lngLoop As Long 'Programming ethics 1. Always start your first line after leaving a line space, and 1 indentation level
With ActiveSheet
For lngLoop = 2 To .Cells(Rows.Count, 1).End(xlUp).Row ' Programming ethics 3. Always indent your loops, case statements and with constructors
Call SendMessage(strTo:=.Cells(lngLoop, 1).Value, strCC:=.Cells(lngLoop, 2).Value, strBCC:=.Cells(lngLoop, 7).Value, strMessage:=.Cells(lngLoop, 8).Value, strSubject:=.Cells(lngLoop, 3).Value, strAttachmentPath:=.Cells(lngLoop, 6).Value, rngToCopy:=.Cells(lngLoop, 9))
Next lngLoop
End With 'Programming ethics 2. Always end your last line leaving a line space before ending the sub or function, and having indendation level of 1
End Sub
Sub SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional strAttachmentPath As String, Optional rngToCopy As Range, Optional blnShowEmailBodyWithoutSending As Boolean = False)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
Exit Sub
End If
' Create the Outlook session.
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo -1: On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
If Trim(strTo) <> "" Then
Set objOutlookRecip = .Recipients.Add(strTo)
objOutlookRecip.Type = olTo
End If
' Add the CC recipient(s) to the message.
If Trim(strCC) <> "" Then
Set objOutlookRecip = .Recipients.Add(strCC)
objOutlookRecip.Type = olCC
End If
' Add the BCC recipient(s) to the message.
If Trim(strBCC) <> "" Then
Set objOutlookRecip = .Recipients.Add(strBCC)
objOutlookRecip.Type = olBCC
End If
' Set the Subject, Body, and Importance of the message.
If strSubject = "" Then
strSubject = "This is an Automation test with Microsoft Outlook"
End If
.Subject = strSubject
If strMessage = "" Then
strMessage = "This is the body of the message." & vbCrLf & vbCrLf
End If
.Importance = olImportanceHigh 'High importance
If Not strMessage = "" Then
.Body = strMessage & vbCrLf & vbCrLf
End If
If Not rngToCopy Is Nothing Then
.HTMLBody = .Body & RangetoHTML(rngToCopy)
End If
' Add attachments to the message.
If Not IsMissing(strAttachmentPath) Then
If Len(Dir(strAttachmentPath)) <> 0 Then
Set objOutlookAttach = .Attachments.Add(strAttachmentPath)
Else
MsgBox "Unable to find the specified attachment. Sending mail anyway."
End If
End If
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
' Should we display the message before sending?
If blnShowEmailBodyWithoutSending Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
Set objOutlookMsg = Nothing
Set objOutlookAttach = Nothing
Set objOutlookRecip = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Copy the range and create a workbook to receive the data.
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
' Publish the sheet to an .htm file.
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
' Read all data from the .htm file into the RangetoHTML subroutine.
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
' Close TempWB.
TempWB.Close savechanges:=False
' Delete the htm file.
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function -
lappy
őstag
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub
Sub Combine_Workbooks_Select_Files()
Dim MyPath As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim SaveDriveDir As String
Dim FName As Variant
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
SaveDriveDir = CurDir
ChDirNet "C:\"
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
For Fnum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:A25")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Not enough rows in the sheet. "
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
Set destrange = BaseWks.Range("A" & rnum)
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
End Sub -
lappy
őstag
válasz
lacipapi
#14530
üzenetére
Szia!
Sub SaveWorkbookBackup()
Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean
If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
Set awb = ActiveWorkbook
If awb.Path = "" Then
Application.Dialogs(xlDialogSaveAs).Show
Else
BackupFileName = awb.FullName
i = 0
While InStr(i + 1, BackupFileName, ".") > 0
i = InStr(i + 1, BackupFileName, ".")
Wend
If i > 0 Then BackupFileName = Left(BackupFileName, i - 1)
BackupFileName = BackupFileName & "_masolat" & ".xls"
OK = False
On Error GoTo NotAbleToSave
With awb
Application.StatusBar = "Munkafüzet mentése"
.Save
Application.StatusBar = "Munkafüzet mentése..."
.SaveCopyAs BackupFileName
OK = True
End With
End If
NotAbleToSave:
Set awb = Nothing
Application.StatusBar = False
If Not OK Then
MsgBox "Biztonsági másolat nem kerül mentésre!", vbExclamation, ThisWorkbook.Name
End If
End Sub -
lappy
őstag
válasz
D@ni88
#14257
üzenetére
Szia!
itt van egy txt beolvasóPublic Sub ImportTextFile(FName As String, Sep As String)
Dim RowNdx As Long
Dim ColNdx As Integer
Dim TempVal As Variant
Dim WholeLine As String
Dim Pos As Integer
Dim NextPos As Integer
Dim SaveColNdx As Integer
Application.ScreenUpdating = False
'On Error GoTo EndMacro:
SaveColNdx = ActiveCell.Column
RowNdx = ActiveCell.Row
Open FName For Input Access Read As #1
While Not EOF(1)
Line Input #1, WholeLine
If Right(WholeLine, 1) <> Sep Then
WholeLine = WholeLine & Sep
End If
ColNdx = SaveColNdx
Pos = 1
NextPos = InStr(Pos, WholeLine, Sep)
While NextPos >= 1
TempVal = Mid(WholeLine, Pos, NextPos - Pos)
Cells(RowNdx, ColNdx).Value = TempVal
Pos = NextPos + 1
ColNdx = ColNdx + 1
NextPos = InStr(Pos, WholeLine, Sep)
Wend
RowNdx = RowNdx + 1
Wend
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #1
End Sub
Sub DoTheImport()
Dim FileName As Variant
Dim Sep As String
FileName = Application.GetOpenFilename(FileFilter:="Text File (*.txt),*.txt")
If FileName = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Sep = Application.InputBox("Írjon be egy elválasztó karaktert.", Type:=2)
If Sep = vbNullString Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Debug.Print "FileName: " & FileName, "Separator: " & Sep
ImportTextFile FName:=CStr(FileName), Sep:=CStr(Sep)
End Sub -
#13668
Delila_1
veterán
Bocimaster
#13667
Delila_1
veterán
válasz
Bocimaster
#13667
üzenetére
A napokban írtam valakinek erre a feladatra egy makrót. Nála az azonosító, ami Nálad a telephely, az A oszlopban van.
A makró telephelyenként szétdobja külön lapokra a Munka1 lap adatait, majd minden lapot áttesz külön füzetbe, és a telephely nevén lementi. Írtam bele megjegyzéseket, aszerint módosíts a makrón.
Sub Telephelyek()
Dim sor As Double, usor As Double, usor_1 As Double, nev$, WS1 As Worksheet
Dim utvonal$, lap%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
utvonal = "E:\Eadat\" 'itt írd be a saját útvonaladat ehelyett, ügyelj a \ jelekre
usor = Cells(Rows.Count, "A").End(xlUp).Row
Set WS1 = Sheets("Munka1") 'ide jön a saját indító lap%od neve
'Másolás lap%okra
For sor = 2 To usor
nev$ = WS1.Cells(sor, 1)
On Error GoTo Uj_lap
usor_1 = Sheets(nev$).Cells(Rows.Count, "A").End(xlUp).Row + 1
'a következő 2 sorban írd át a "K"-t az utolsó oszlopod azonosítójára
If usor_1 = 2 Then Range(WS1.Cells(1, "A"), WS1.Cells(1, "K")).Copy Sheets(nev$).Cells(1)
Range(WS1.Cells(sor, "A"), WS1.Cells(sor, "K")).Copy Sheets(nev$).Cells(usor_1, "A")
Next
'**********************************************************************************************
'Ha nem kell külön füzetekbe menteni a lapokat, ezt a részt hagyd ki
'Mentés, zárás
For lap% = 1 To Sheets.Count - 1
nev$ = utvonal & Sheets(1).Cells(2, "A")
Sheets(1).Move
ActiveWorkbook.SaveAs Filename:=nev$, FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
Next
'**********************************************************************************************
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Kész"
Exit Sub
Uj_lap:
If Err = 9 Then
Worksheets.Add.Name = nev$
Resume 0
Else
Error Err
End If
End Sub -
Delila_1
veterán
Ez a makró megcsinálja. Előbb új lapokra másolja az egyes sorokat, mindegyiket olyan nevű lapra, amilyen adatot tartalmaz az adott sor első (A) cellája.
Ezután az egyes lapokat áthelyezi 1-1 új fájlba, aminek a neve a lapnév + "_adott adat".Az utvonal = "E:\Eadat\" sorban írd át az útvonalat a sajátodra, a végén is legyen \ jel, mint itt.
A nev$ = utvonal & Sheets(1).Name & "_adott adat.xls" sor végén az .xls helyett írj .xlsx-et, ha 2003-asnál magasabb verziót alkalmazol.Címsort feltételezek, ezért az első ciklust (sorok másolása másik lapokra) a 2. sortól kezdtem a For sor% = 2 To usor% sorban. Címsor nélkül legyen ez a sor For sor% = 1 To usor%.
Sub Ujak()
Dim sor%, usor%, usor_1%, nev$, WS1 As Worksheet
Dim utvonal$, lap%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
utvonal = "E:\Eadat\" 'Itt írd be a saját útvonaladat ehelyett
usor% = Cells(Rows.Count, "A").End(xlUp).Row
Set WS1 = Sheets("Kezdőlap")
For sor% = 2 To usor%
nev$ = WS1.Cells(sor%, "A")
On Error GoTo Uj_lap
usor_1% = Sheets(nev$).Cells(Rows.Count, "A").End(xlUp).Row + 1
WS1.Rows(sor%).Copy Sheets(nev$).Cells(usor_1%, "A")
Next
For lap% = 1 To Sheets.Count - 1
nev$ = utvonal & Sheets(1).Name & "_adott adat.xls"
Sheets(1).Move
ActiveWorkbook.SaveAs Filename:=nev$, FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Kész"
Exit Sub
Uj_lap:
If Err = 9 Then
Worksheets.Add.Name = nev$
Resume 0
Else
Error Err
End If
End Sub -
Delila_1
veterán
válasz
plaschil
#13220
üzenetére
A makró az N oszlopba kigyűjti az A oszlopban lévő szövegeket, és mindegyik mellé beírja csökkenő sorrendben a hozzá tartozó top5-öt az O:S oszlopba.
Ha 100-nál több féle adatod lehet az A oszlopban, a makróban jelzett sorban írhatod át.Sub Top5()
Dim sor As Long, sor1 As Long
Dim usor As Long, usor1, cim, ertek
Dim T(100, 5) '***** Itt írd át a 100-at *****
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
usor = ActiveSheet.UsedRange.Rows.Count
Columns("A:A").Select
Range("A1:A" & usor).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"N1"), Unique:=True
usor1 = Range("N1").End(xlDown).Row
For sor1 = 2 To usor1
cim = Cells(sor1, 14)
For sor = 2 To usor
ertek = Cells(sor, 2)
If Cells(sor, 1) = cim Then
If ertek > T(sor1 - 1, 1) Then
T(sor1 - 1, 5) = T(sor1 - 1, 4)
T(sor1 - 1, 4) = T(sor1 - 1, 3)
T(sor1 - 1, 3) = T(sor1 - 1, 2)
T(sor1 - 1, 2) = T(sor1 - 1, 1)
T(sor1 - 1, 1) = ertek
GoTo Köv
End If
If ertek > T(sor1 - 1, 2) Then
T(sor1 - 1, 5) = T(sor1 - 1, 4)
T(sor1 - 1, 4) = T(sor1 - 1, 3)
T(sor1 - 1, 3) = T(sor1 - 1, 2)
T(sor1 - 1, 2) = ertek
GoTo Köv
End If
If ertek > T(sor1 - 1, 3) Then
T(sor1 - 1, 5) = T(sor1 - 1, 4)
T(sor1 - 1, 4) = T(sor1 - 1, 3)
T(sor1 - 1, 3) = T(sor1 - 1, 2)
T(sor1 - 1, 3) = ertek
GoTo Köv
End If
If ertek > T(sor1 - 1, 4) Then
T(sor1 - 1, 5) = T(sor1 - 1, 4)
T(sor1 - 1, 4) = T(sor1 - 1, 3)
T(sor1 - 1, 4) = ertek
GoTo Köv
End If
If ertek > T(sor1 - 1, 5) Then T(sor1 - 1, 5) = ertek
End If
Köv:
Next
Range("O" & sor1) = T(sor1 - 1, 1)
Range("P" & sor1) = T(sor1 - 1, 2)
Range("Q" & sor1) = T(sor1 - 1, 3)
Range("R" & sor1) = T(sor1 - 1, 4)
Range("S" & sor1) = T(sor1 - 1, 5)
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub -
#12912
Fire/SOUL/CD
félisten
föccer
#12909
válasz
föccer
#12909
üzenetére
Ez meg egy makrós megoldás.
Function CountOfDistinctValues(MyTypeSrcRange As Range) As Long
Dim MyCollection As New Collection
Dim MyCell As Range
Dim MyTypeSrcRange As Range
Application.Volatile
For Each MyCell In MyTypeSrcRange
On Error Resume Next
MyCollection.Add MyCell.Value, CStr(MyCell.Value)
Next MyCell
On Error GoTo 0
CountOfDistinctValues = MyCollection.Values.Count
End FunctionSajnos most nem tudom tesztelni(nincs Office a gépen), csak megírtam, remélhetőleg így is működik...
-
Delila_1
veterán
válasz
mr.nagy
#11565
üzenetére
Teszteld ezzel. Csak estefelé leszek gép közelében, addig biztosan kibuknak a hibák.
A makró első részében (a **-os sorig) az első lap 100. oszlopába teszek egy x-et ahhoz, hogy a második rész gyorsabb futású legyen. Ezt az oszlopot a végén törlöm. Ha foglalt a 100. oszlop (CV), a 100-at a replace funkcióval írd át egy üres oszlop számára. Négy helyen szerepel.Sub szamitas()
Dim WS1 As Worksheet, WS2 As Worksheet, sor%, usor1%, usor2%, lel
Set WS1 = Sheets("első")
Set WS2 = Sheets("második")
WS2.Select
usor1% = Range("G2").End(xlDown).Row
For sor% = 2 To usor1%
On Error GoTo Köv
lel = WS1.Range("E:E").Find(Cells(sor%, "E")).Row
Select Case WS1.Cells(lel, 1)
Case 380
Cells(sor%, 7) = WS1.Cells(lel, 7) + Cells(sor%, 7)
WS1.Cells(lel, 100) = "x"
Case 390
Cells(sor%, 7) = WS1.Cells(lel, 7) - Cells(sor%, 7)
WS1.Cells(lel, 100) = "x"
End Select
Köv:
Next
'***************************************************************************
WS1.Select
usor1% = Range("A2").End(xlDown).Row
For sor% = 2 To usor1%
If Cells(sor%, 1) = 380 And Cells(sor%, 100) <> "x" Then
usor2% = WS2.Range("E2").End(xlDown).Row + 1
Range(Cells(sor%, 2), Cells(sor%, 5)).Copy WS2.Cells(usor2%, 2)
Cells(sor%, 7).Copy WS2.Cells(usor2%, 7)
End If
Next
Columns(100) = ""
End Sub -
#11508
Delila_1
veterán
MaciLaci68
#11503
Delila_1
veterán
válasz
MaciLaci68
#11503
üzenetére
Miért is van erre szükség? Hiszen ha van az aktív cellának neve, akkor a szerkesztőléc bal oldalán láthatod kiírva.
Ez a makró is végig böngészi a neveket, csak egy kicsit gyorsabban.
Sub CellaNeve()
Dim i As Long
For i = 1 To ActiveWorkbook.Names.Count
On Error GoTo Hiba
If ActiveWorkbook.Names(i).RefersToLocal = Selection.Name Then
Range("A1") = ActiveWorkbook.Names(i).Name
Exit Sub
End If
Next
Hiba:
Cells(1) = "A " & ActiveCell.Address & " cella nincs elnevezve"
End Sub -
-
#10373
Fire/SOUL/CD
félisten
Oly
#10372
Előbbire nem tudok így hirtelen mit mondani, másodikra viszont igen:
Private Sub CommandButton1_Click()
Dim MyApplication As Object
Set MyApplication = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Kérem válasszon egy mappát...", 0, OpenAt)
On Error Resume Next
MsgBox (MyApplication.self.Path)
On Error GoTo 0
Set MyApplication = Nothing
End Sub -
#10204
Fire/SOUL/CD
félisten
Oly
#10201
Annyit had javasoljak, hogy a Goto utasítást csak akkor használd, ha nincs más. A strukturált nyelvek esetén a Goto 99%-ban nem szükséges.
If Len(Dir(Cells(7, 26))) = 0 Then GoTo dirmakego
GoTo csvmakegoEgy ilyen szerkezet, minden vizsgán (bármely strukturált nyelvről is legyen szó) elégtelen...
![;]](//cdn.rios.hu/dl/s/v1.gif)
(a többiről a kódodban nem is beszélve)
(És hidd el, nem elfogultságból mondom, mivel kb 6 évet Assembly-ben dolgoztam, ott meg csak ugró utasítások vannak)Javaslom nézz utána az If...Else...EndIf struktúrának, mert szörnyen használod jelenleg...
-
Oly
őstag
válasz
perfag
#10199
üzenetére
Köszi
Meg is csináltam:
Dim biztos As String
biztos = MsgBox("Létrehozzuk a CSV file-t?", vbQuestion + vbYesNo, "Megerősítés")
If biztos = vbNo Then GoTo vege
If Len(Dir(Cells(7, 26))) = 0 Then GoTo dirmakego
GoTo csvmakego
dirmakego:
Dim dirmake As String
dirmake = MsgBox("A megadott elérési útvonal (" & Cells(7, 26) & ") nem létezik. Létrehozzuk most?", vbQuestion + vbYesNo, "Hiba")
If dirmake = vbNo Then GoTo vege
MkDir Cells(7, 26)
MsgBox "A " & Cells(7, 26) & " mappa létrehozva."
csvmakego:
Dim FNV$
Dim FN$
filego:
FNV$ = InputBox("Kérem a fájl nevét!", "Fájl neve")
FN$ = Cells(7, 26) & Format(Now(), "mmdd") & FNV$ & ".csv"
If Len(Dir(FN$)) = 0 Then GoTo nincsilyen
Dim felulir As String
felulir = MsgBox("A file (" & FN$ & ") már létezik! Felülírjuk?", vbQuestion + vbYesNo, "Megerősítés")
If felulir = vbNo Then GoTo filego
nincsilyen:
Application.DisplayAlerts = False
Sheets("table").Select
Sheets("table").Copy
ActiveWorkbook.SaveAs Filename:=FN$, FileFormat:=xlCSV, _
CreateBackup:=False, Local:=True
ActiveWindow.Close
Sheets("make").Select
Range("A11").Select
If Err.Number <> 0 Then
MsgBox "Akkor fuss neki újra! :)"
Else
MsgBox "A file lértehozva: " & FN$, vbInformation, "Sikeresen létrehozva"
End If
vege:
End Sub -
#9803
m.zmrzlina
senior tag
Sir Pocok
#9801
m.zmrzlina
senior tag
válasz
Sir Pocok
#9801
üzenetére
Nem állítom, hogy hibátlan de kiindulásnak jó lesz aztán majd pontosítasz, hogy mit szeretnél:
Sub kerescserel()
Dim amitkeres As String, amirecserel As String
Cells(1, 1).Select
amitkeres = InputBox("Add meg a keresni kívánt számot!", "Keresés")
amirecserel = InputBox("Mire szeretnéd cserélni?", "Keresés")
Do Until IsEmpty(ActiveCell.Offset(1, 0)) = True
On Error GoTo nincstobb
Cells.Find(What:=amitkeres, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Select
If ActiveCell.Value = amitkeres Then ActiveCell.Value = amirecserel
Loop
nincstobb:
MsgBox ("A számok cseréje megtörtént.")
End SubAz A1 cellától keres lefelé a legutolsóig és ha megtalálta az első inputboxban bevitt karaktersorozatot akkor kicseréli arra amit a második inputboxban bevittél. Ez kicsit gyorsabb mint a beépített (Ctrl+H) módszer.
-
#9493
m.zmrzlina
senior tag
Fire/SOUL/CD
#9492
m.zmrzlina
senior tag
válasz
Fire/SOUL/CD
#9492
üzenetére
Ezt nem igazán értem. Próbáltam Inputboxra alkalmazni de nem ment.
Ide kellene valahogy beilleszteni:
Private Sub CommandButton1_Click()
Dim tech As String
start:
tech = InputBox("Add meg a technikus nevét!" + Chr(13) + Chr(13) + "A lista törléséhez nyomj < SPACE >-t!")
If InStr(tech, " ") = 1 Then tech = " " Else tech = tech
If tech = vbCancel Then Exit Sub
Select Case tech
' Case Is = vbCancel
' Exit Sub
Case Is = " "
GoTo clearcontent
Case Is = ""
MsgBox "Nem adtad meg a technikus nevét!", vbCritical, "Hiányzó adat!"
GoTo start
Case Is <> ""
GoTo paste_list
End Select -
#9488
m.zmrzlina
senior tag
m.zmrzlina
senior tag
Ötletre volna szükségem.
A következő kód egy ActiveX parancsgombhoz van rendelve és azt csinálja, (meg még sok minden mást de ez most nem érdekes) hogy a vágólapról megfelelő helyre beilleszt egy 1 oszlop széles változó hosszúságú tartományt, vagy ha a felhasználó <Szóköz>-t nyom akkor törli a meglévőt, vagy nem engedi elfelejteni a "névadást"(Select Case 2. ág)
Private Sub CommandButton1_Click()
Dim tech As String
start:
tech = InputBox("Add meg a technikus nevét!" + Chr(13) + Chr(13) + "A lista törléséhez nyomj < SPACE >-t!")
Select Case tech
Case Is = " "
GoTo clearcontent
Case Is = ""
MsgBox "Nem adtad meg a technikus nevét!" + Chr(13) + Chr(13) + "Pótold a hiányosságot!", vbCritical, "Hiányzó adat!"
GoTo start
Case Is <> ""
GoTo paste_list
End Select
paste_list:
Application.ScreenUpdating = False
CommandButton1.Caption = tech
Cells(2, 2).Value = tech
Cells(4, 2).Select
On Error Resume Next
Selection.PasteSpecial Paste:=xlPasteAll
If Err.Number <> 0 Then
MsgBox "Jelöld ki a panellistát!" & Chr(13) & "Hibakód:" & Err.Number, vbCritical, "Hiba!!!"
Cells(2, 2).Select
Range(ActiveCell, ActiveCell.End(xlDown)).ClearContents
CommandButton1.Caption = "Tech_1"
Exit Sub
End If
'stb...stb...stb...Az a gondom, hogy ha a felhasználó izgalmában véletlenül több szóközt nyom egy helyett akkor nem a régi lista törlése történik hanem beilleszti a vágólapot úgy hogy a parancsgomb felirata " "(kvázi semmi) lesz ami kód szempontjából egy teljesen normális működés de nem ez a cél.
Ezt a felhasználói hibát kellene lekezelni a legegyszerűbben. Nem baj ha nem <Szóköz>-zel törlünk, lehet akár <Del> vagy <Backspace> is.
Hogyan lehet ezt megoldani?
-
#9363
Delila_1
veterán
Fire/SOUL/CD
#9360
Delila_1
veterán
válasz
Fire/SOUL/CD
#9360
üzenetére
Szerintem elég ennyi, mivel 1 név csak 1× szerepel a C2:CX2 tartományban:
Sub Keres()
Range("C2:CX2").Select
amitkeres = InputBox("Add meg a keresni kívánt nevet!", "Keresés")
On Error GoTo Nincs
Selection.Find(What:=amitkeres, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Select
Selection.Font.Bold = True
Exit Sub
Nincs:
MsgBox ("A keresett név nincs a listában.")
End SubA lényeg, hogy kijelölöm a tartományt, és NEM Cells.Find, hanem Selection.Find legyen a kereső sor.
-
#9360
Fire/SOUL/CD
félisten
m.zmrzlina
#9359
válasz
m.zmrzlina
#9359
üzenetére
Akkor talán így
Sub find()
eleje:
On Error Resume Next
Cells(2, 3).Activate
amitkeres = InputBox("Add meg a keresni kívánt nevet!", "Keresés", amitkeres, 13000, 100)
Cells.find(What:=amitkeres, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
If Err.Number <> 0 Or ActiveCell.Row <> 2 Then
MsgBox ("A keresett név nincs a listában.")
GoTo eleje
End If
End Sub -
#9355
m.zmrzlina
senior tag
Fire/SOUL/CD
#9354
m.zmrzlina
senior tag
válasz
Fire/SOUL/CD
#9354
üzenetére
Ezt sikerült kiötleni, úgy tűnik működik.
Sub find()
eleje:
Cells(2, 3).Activate
amitkeres = InputBox("Add meg a keresni kívánt nevet!", "Keresés", amitkeres, 13000, 100)
On Error Resume Next
Cells.find(What:=amitkeres, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
If Err.Number = 91 Then
MsgBox ("A keresett név nincs a listában.")
GoTo eleje
End If
If ActiveCell.Row <> 2 Then
Cells(2, 3).Activate
MsgBox ("A keresett név nincs a listában.")
GoTo eleje
End If
End SubMűködni működik de jó ez így?
-
#9351
m.zmrzlina
senior tag
m.zmrzlina
#9348
m.zmrzlina
senior tag
válasz
m.zmrzlina
#9348
üzenetére
Érdekes, hogy második alkalommal is az On Error GoTo uzenet utáni sor okozza a hibát mint elsőre de először el tud menni az uzenet: címkére másodszor már nem.Akkor sem ha nem ugyanaz az inputbox tartalma mint először.
Magyarul, ha kétszer gépeli el a júzer a nevet akkor ugyanúgy kiakad a kód mintha nem is lenne benne hibakezelés.
-
#9341
m.zmrzlina
senior tag
pirit28
#9338
m.zmrzlina
senior tag
válasz
pirit28
#9338
üzenetére
Ha egy név csak egyszer szerepel a listában akkor lehet ez egy megoldás:
Sub find()
eleje:
Cells(2, 3).Activate
amitkeres = InputBox("Add meg a keresni kívánt nevet, vagy név részletet!", "Keresés", amitkeres)
On Error GoTo uzenet
Cells.find(What:=amitkeres, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
If ActiveCell.Row <> 2 Then
Cells(2, 3).Activate
GoTo uzenet
End If
Exit Sub
uzenet:
MsgBox ("A keresett név nincs a listában.")
GoTo eleje
End SubNincs bolondbiztossá téve még, csak próbálkozom.
-
Heno1974
csendes tag
syasztok.tudna nekem segítteni valaki??
sub szürés ()For k = 1 To 2000
Let x = ActiveCellActiveCell.Offset(1, 0).Range("A1").Select
Let y = ActiveCell
If y = "" Then
GoTo TestforBlank
End If
If x = y Then
Selection.EntireRow.Delete
ActiveCell.Offset(-1, 0).Range("A1").SelectEnd If
Next k
TestforBlank:
End suba K val áll i hibával,
szürni szeretnék 2003 excelbe, hogy az ismétlődéseket távolítsa el .
azt is meg kéne adni, hogy ha nincs adat akkor fejezze be a szürést.
valahogy igy kellene asszem:
For k <> "null"
ha jól tudom.
számokat kéne szürnöm, de K nál kiáll hibával
-
#9219
m.zmrzlina
senior tag
m.zmrzlina
senior tag
A következő kódrészlettel az a bajom, hogy az a sor amivel egy másik munkafüzetben végzett kijelölést értékként akarok beilleszteni 1004-es hibakóddal kiakad. A makró munkafüzetében tett kijelölést hiba nélkül értékként is be tudja illeszteni.
Az xlPasteAll viszont így is úgy is gond nélkül lefut.
Mi lehet az oka, merre keresgéljek? A cél az lenne, hogy a másik munkafüzet kijelölését értékként lehessen beilleszteni.
paste_list:
Application.ScreenUpdating = False
CommandButton1.Caption = tech
Cells(2, 2).Value = tech
Cells(4, 2).Select
On Error GoTo error_1
Selection.PasteSpecial Paste:=xlPasteAll
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.Cells(Selection.Rows.Count + 1, 1).Select
If ActiveCell.Value <> "" Then
Range(ActiveCell, ActiveCell.End(xlDown)).Select
End If
....stb
....stb -
#8557
m.zmrzlina
senior tag
m.zmrzlina
senior tag
Van egy makróm ami azt csinálja, hogy a felhasználó által egy txt fájlban kijelölt szöveget beilleszti egy munkalapra elvégez bizonyos ellenőrzéseket majd megformázza.
A következő módszerrel egy felhasználói hibát szeretnék kezelni ami abból adódik, hogy nem tett semmit a vágólapra mielőtt elindította a makrót. Így szeretném csinálni:
Cells(1, 1).Select
On Error GoTo hiba
ActiveSheet.Paste
'további utasítások (jó ág)
hiba: 'hiba ág
MsgBox "Nincs mit beilleszteni." + Chr(13) + "Végezd el a kijelölést!", vbCritical, "Figyelem !!!"
Exit SubEz most úgy működik, hogy akár üres a vágólap akár nem a hibaüzenet mindenképpen megjelenik és folytatódik tovább a program. Mintha mindkét ág lefutna függetlenül attól hogy volt-e hiba vagy sem.
Mit rontok el?
-
#8457
Fire/SOUL/CD
félisten
zsotesz81
#8456
válasz
zsotesz81
#8456
üzenetére
Hali!
Ebből a kódból az alábbi részből meríthetsz ihletet
On Error Resume Next
Set My_Sheet = Sheets(My_Sheet_Name)
On Error GoTo 0
If Not My_Sheet Is Nothing Then
My_Sheet.Delete
End IfEz létező munkalap esetén törli azt, egy kis átalakítással neked is megfelelhet, de ez függ a programod felépítésétől.
Másik alapmódszer az szokott lenni, hogy egy ciklussal végigmész a munkalapokon, a cikluson belül megvizsgálod a nevét, ha megegyezik, akkor valamilyen változót magasra állítasz és kilépsz a ciklusból. Ezt követően megvizsgálod azt a bizonyos változót, éa feltételnek megfelelően kihagysz programrészt.
Fire.
-
#8450
perfag
aktív tag
m.zmrzlina
#8449
perfag
aktív tag
válasz
m.zmrzlina
#8449
üzenetére
A Microsoft támogatás szerint "a line label defined in another procedure, you receive the error message "Label not defined." This message means that the label is not defined in the current Sub or Function." ez nem fog menni.
Megoldást én az Error Handling-ot felhasználva keresnék, Chip Pearson ezt írja: "Every procedure need not have a error code. When an error occurs, VBA uses the last On Error statement to direct code execution. If the code causing the error is in a procedure with an On Error statement, error handling is as described in the above section. However, if the procedure in which the error occurs does not have an error handler, VBA looks backwards through the procedure calls which lead to the erroneous code."
Az Err.Number-nek utánanéznék, milyen saját értéket adhatnék és ezzel vissza tudnék térni a főciklus ErrorHandlerébe, ahol egy GoTo, vagy GoSub a kívánt helyre vinné a vezérlést. -
#8449
m.zmrzlina
senior tag
Delila_1
#8448
m.zmrzlina
senior tag
válasz
Delila_1
#8448
üzenetére
A kód szerkezete olyan, hogy van egy főciklus ami vegyesen tartalmaz szubrutin hívásokat és programsorokat is.
A probléma ott kezdődik, ha egy szubrutinban bekövetkezett feltétel esetén a főciklus megadott pontján szeretném folytatni a program futását.
Ha egy cikluson belül vagyok akkor GoTo címke és készen van. Azonban ha a cimke a szubrutinon kívül van akkor jön ez a hibaüzenet.
Gondoltam van valami módja ennek a teljes munkafüzetre kiterjedő cimke megadásának ahhoz hasonlóan mint hogy változót is másképp kell deklarálni, ha nem csak egy szubrutinban akarom használni.
-
#8433
m.zmrzlina
senior tag
m.zmrzlina
senior tag
Do
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then
Select Case Params
Case Is = 1
Cells(1 + Params, columnid_1).Select
cikl = columnid_1
Case Is = 2
Cells(1 + Params, columnid_2).Select
cikl = columnid_2
Case Is = 3
Cells(1 + Params, columnid_3).Select
cikl = columnid_3
Case Is = 4
Cells(1 + Params, columnid_4).Select
cikl = columnid_4
Case Is = 5
Cells(1 + Params, columnid_5).Select
cikl = columnid_5
Case Else
Range("I1").Select
End Select
For k = cikl To 1440
With Selection.Interior
.Pattern = xlSolid
.ColorIndex = 4
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.Offset(0, 1).Select
Next k
Else Goto start
Loop Until Mid(ActiveCell.Text, 13, 1) = ParamsA fenti programrészlet Futtatáskor a következő hibaüzenetet adja
LOOP without DOMi lehet az oka?
Próbáltam már kikommentezni a Case szerkezetet és a ciklust is de nem jöttem rá mi kavar be. -
#8353
Fire/SOUL/CD
félisten
Fire/SOUL/CD
#8352
válasz
Fire/SOUL/CD
#8352
üzenetére
Hali!
Private Sub CommandButton1_Click()
Dim My_Sheet As Worksheet
Dim My_Sheet_Name As String
Dim My_Range As Range
Dim My_Column As String
'Oszlop, amelyikben szállítólevélszámok vannak
'(Ugyanebben az oszlopban lesznek majd, az új munkalapon is)
My_Column = "D"
'Az első adat az oszlopban
My_Row = 2
'A létrehozandó, összesítő munkalap neve
My_Sheet_Name = "FSCD_Összesítés"
Application.DisplayAlerts = False
On Error Resume Next
Set My_Sheet = Sheets(My_Sheet_Name)
On Error GoTo 0
If Not My_Sheet Is Nothing Then
My_Sheet.Delete
End If
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = My_Sheet_Name
k = 0
For i = 1 To Worksheets.Count - 1
Worksheets(i).Select
Worksheets(i).Range(My_Column & My_Row).Select
Set My_Range = Worksheets(i).Range(My_Column & My_Row & ":" & My_Column & Worksheets(i).UsedRange.Rows(Worksheets(i).UsedRange.Rows.Count).Row)
My_Range.Select
For Each CurrCell In My_Range
Worksheets(My_Sheet_Name).Range(My_Column & 1 + k) = CurrCell.Value
k = k + 1
Next CurrCell
Set My_Range = Nothing
Next i
Worksheets(My_Sheet_Name).Select
Set My_Sheet = Nothing
Application.DisplayAlerts = True
End SubFire.
[ Módosította: Ndruu ]
-
#8350
Fire/SOUL/CD
félisten
Charlie Gordon
#8349
válasz
Charlie Gordon
#8349
üzenetére
Hali!
Oksa, akkor
1. Készíts másolatot az excel fájlról, biztos ami biztos
2. Nyisd meg és az első munkalapra tegyél egy CommandButtont
3. Kattints rá duplán, a megjelenő ablakban törölj mindent és illeszd be az alábbi kódotPrivate Sub CommandButton1_Click()
Dim My_Sheet As Worksheet
Dim My_Sheet_Name As String
Dim My_Range As Range
Dim My_Column As String
'Oszlop, amelyikben szállítólevélszámok vannak
'(Ugyanebben az oszlopban lesznek majd, az új munkalapon is)
My_Column = "D"
'A létrehozandó, összesítő munkalap neve
My_Sheet_Name = "FSCD_Összesítés"
Application.DisplayAlerts = False
On Error Resume Next
Set My_Sheet = Sheets(My_Sheet_Name)
On Error GoTo 0
If Not My_Sheet Is Nothing Then
My_Sheet.Delete
End If
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = My_Sheet_Name
k = 1
For i = 1 To Worksheets.Count - 1
Worksheets(i).Select
Worksheets(i).Range(My_Column & "1").Select
Set My_Range = Worksheets(i).Range(My_Column & "1:" & My_Column & Worksheets(i).UsedRange.Rows.Count)
My_Range.Select
For Each CurrCell In My_Range
Worksheets(My_Sheet_Name).Range(My_Column & k) = CurrCell.Value
k = k + 1
Next CurrCell
Set My_Range = Nothing
Next i
Worksheets(My_Sheet_Name).Select
Set My_Sheet = Nothing
Application.DisplayAlerts = True
End Sub4. kattints a CommandButtonra
Ez a makró létrehoz a munkalapok legvégén egy új munkalapot, abba másolja az adatokat.
Fire.
-
Delila_1
veterán
-
Delila_1
veterán
válasz
motinka
#7631
üzenetére
Több dolgot kellett átírni benne. A Select Case sorban most már nem az A1-et [cells(1)], hanem a B5 cellát [cells(5,2)] kell figyeltetni.
Az ÖSSZESnél sem írhatsz XX oszlopot. A kiterjesztésből gondolom, hogy a 2007-es verziónál előbbit használsz, ahol az utolsó oszlop az IV.
A fentieket kijavítva:Private Sub Worksheet_Change(ByVal Target As Range)
Dim kezd As String, vég As String
If Target.Address = "$B$5" Then
Select Case Cells(5, 2)
Case "CSABA"
kezd = "D": vég = "F": GoTo Rejt
Case "JÁNOS"
kezd = "G": vég = "I": GoTo Rejt
Case "FERENC"
kezd = "J": vég = "L": GoTo Rejt
Case "LÁSZLÓ"
kezd = "M": vég = "O": GoTo Rejt
Case "TIBOR"
kezd = "P": vég = "R": GoTo Rejt
Case "ÖSSZES"
Columns("D:IV").Hidden = False
End Select
End If
Exit Sub
Rejt:
Columns("D:IV").Hidden = True
Columns(kezd & ":" & vég).Hidden = False
End Sub -
#7610
Fire/SOUL/CD
félisten
Delila_1
#7609
válasz
Delila_1
#7609
üzenetére
Hali!
Meg van még egy "hiba" benne, de ez csak akkor okozhat problémát, ha a P oszlop is felhasználásra kerül. Ha László lesz kiválasztva, akkor az MNO oszlopokat kellene csak látni, ellenben a makróban MNOP oszlopok lesznek láthatóak .
Case "László"
kezd = "M": vég = "P": GoTo RejtÉn sem figyeltem rá tegnap, de mint írtam, ez csak akkor okoz "gondot", ha a P oszlopnak is lesz funkciója, azaz pl bekerül egy újabb név és ahhoz tartozó táblzatoszlopok (PQR).
Fire.
-
#7606
Fire/SOUL/CD
félisten
Fire/SOUL/CD
#7605
válasz
Fire/SOUL/CD
#7605
üzenetére
Hali!
Ja nem teljesen azt csinálja, amit kértél "Az összesnél kinyílna a teljes táblázat." kimaradt, úgy hogy Delila_1 utólagos engedélyével beleírtam azt a 2 sort a kódba.
Neked meg még annyi dolgod lesz, hogy a listában szerepeljen az Összes elem is a neveken kívül.Private Sub Worksheet_Change(ByVal Target As Range)
Dim kezd As String, vég As String
If Target.Address = "$A$1" Then
Select Case Cells(1)
Case "Csaba"
kezd = "D": vég = "F": GoTo Rejt
Case "János"
kezd = "G": vég = "I": GoTo Rejt
Case "Ferenc"
kezd = "J": vég = "L": GoTo Rejt
Case "László"
kezd = "M": vég = "P": GoTo Rejt
Case "Összes"
Columns("D:O").Hidden = False
End Select
End If
Exit Sub
Rejt:
Columns("D:O").Hidden = True
Columns(kezd & ":" & vég).Hidden = False
End SubFire.
-
Delila_1
veterán
válasz
motinka
#7601
üzenetére
Itt a makró, elég jól látszik belőle, melyik adatokat kell átírnod. A Case utasításokból az End Select sor elé akárhány újat beszúrhatsz. Ennek alapján eldöntheted, mit akarsz később a további adatokhoz idomítani, a különböző nézeteket, vagy a makrót.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim kezd As String, vég As String
If Target.Address = "$A$1" Then
Select Case Cells(1)
Case "Csaba"
kezd = "D": vég = "F": GoTo Rejt
Case "János"
kezd = "G": vég = "I": GoTo Rejt
Case "Ferenc"
kezd = "J": vég = "L": GoTo Rejt
Case "László"
kezd = "M": vég = "P": GoTo Rejt
End Select
End If
Exit Sub
Rejt:
Columns("D:O").Hidden = True
Columns(kezd & ":" & vég).Hidden = False
End SubA makrót a kérdéses laphoz kell rendelned. Lapfülön jobb klikk, Kód megjelenítése, a VB szerkesztőben jobb oldalon kapott üres lapra másold be.
Szerk.: a Columns("D:O").Hidden = True sorban a kettőspont után nem nulla van, hanem O betű, az utolsó felhasznált oszlopod betűjele.
-
#7093
Delila_1
veterán
nagytomi10
#7088
Delila_1
veterán
válasz
nagytomi10
#7088
üzenetére
Hibakezeléssel:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Sheets("Találatok").Select
ActiveSheet.Rows("2").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
sor_k = 2
sz = Sheets("Munka2").Cells(1)
Sheets("Munka1").Select
On Error GoTo Hiba
Cells.Find(What:=sz, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
sor = Selection.Row: sor_m = sor + 1
Rows(sor).Copy Sheets("Találatok").Rows(sor_k)
sor_k = sor_k + 1
Do 'Keresés ismétlése
Cells.FindNext(After:=ActiveCell).Activate
sor = Selection.Row
Rows(sor).Copy Sheets("Találatok").Rows(sor_k)
sor_k = sor_k + 1
Loop While sor >= sor_m
Sheets("Találatok").Select
usor = ActiveSheet.UsedRange.Rows.Count + 1
ActiveSheet.Rows(usor).Select
Selection.Delete Shift:=xlUp
ActiveSheet.Cells(1).Select
Application.ScreenUpdating = True
Exit Sub
Hiba:
MsgBox "Nincs '" & sz & "' érték a Munka1 lapon"
End Sub2003-as verzióban írtam, ahhoz nem kellett az ActiveSheet. Látom, áttetted a Munka2!A1-be a keresendő értéket. Jobb, mert ha az adatok között egyébként nem szerepelne, a Find ezt az egyet megtalálná.
-
#6865
Fire/SOUL/CD
félisten
Sickboy25
#6859
válasz
Sickboy25
#6859
üzenetére
Hali!
Makró-kód
Private Sub Worksheet_Change(ByVal Target As Range)
X = Range(Target.Address)
Y = 50
On Error Resume Next
If Not Intersect(Range("P3:V25"), Range(Target.Address)) Is Nothing Then
If X <> "" Then
Application.EnableEvents = False
Range(Target.Address) = Y / X * 100
Application.EnableEvents = True
End If
End If
On Error GoTo 0
End SubAmit állíthatsz, az az Y(állandó, én most 50-nek vettem) illetve az adattartomány(esetünkben P3:V25). Természetesen ebben a tartományban nem lehet a táblázat fejléce csak számadatok. Amennyiben pl betűt is tartalmaz a cella(mert véletlenül melléütsz), akkor nem történik semmi, bekerül amit beírtál, nyilván nem lehet vele számolni.
Fire.
UI: Ha azt akarod kiszámolni, hogy hány százaléka X-nek Y, akkor korábban rossz képletet adtál meg. Helyesen Y/X*100...
-
mr.nagy
tag
válasz
mr.nagy
#6851
üzenetére
Időközben magam is törtem a felyem és egy ilyen kódot csináltam:
Private Sub CommandButton1_Click()
Sheets("tábla").Activate
On Error Resume Next
ActiveSheet.Shapes("kép").Select
Selection.Delete
On Error GoTo 0
Dim myPic As Object
Set myPic = Sheets("tábla").Pictures.Insert(Sheets("adatok").Range("C1"))
myPic.Left = Sheets("tábla").Range("C5").Left + ((Sheets("tábla").Range("C5").Width - myPic.Width) / 2)
myPic.Top = Sheets("tábla").Range("C5").Top + ((Sheets("tábla").Range("C5").Height - myPic.Height) / 2)
myPic.Name = ("kép")
End SubEddig úgy tűnik, hogy működik, de ha van jobb özlet nyitott vagyok rá és megköszönöm!
-
#5921
Fire/SOUL/CD
félisten
sonar
#5918
Hali!
Látom ulrik19 kolléga megelőzött, de ha már én is megírtam, akkor be is rakom.
Ez Microsoft ActiveX Data Objects 6.0 Library bővítménnyel és adatkapcsolattal, valamint mysql connector ODBC bővítménnyel megtámogatva van elkészítve. Természetesen kifogástalanul működik. Egy excel_mysql nevű adatbázis, test nevű tábláján megy végig és írja ki sorban a mezőket.Private Sub CommandButton1_Click()
Dim FSCD_SQLConnection As ADODB.Connection
Dim FSCD_Recordset As ADODB.Recordset
Dim FSCD_SQLConnectionString As String
Dim FSCD_SQLCommand As String
Dim FSCD_MYSQL_Table As String
On Error GoTo FSCD_ErrorHandler
FSCD_MYSQL_Table = "test"
FSCD_SQLConnectionString = "Provider=MSDASQL.1;Persist Security Info=True;" & _
"User ID=root;Extended Properties='';DSN=Excel_MySQL_Tutorial;" & _
"UID=root;SERVER=127.0.0.1;DATABASE=excel_mysql;PORT=3306;'';" & _
"Initial Catalog=excel_mysql;Initial Catalog=excel_mysql"
Set FSCD_SQLConnection = New ADODB.Connection
FSCD_SQLConnection.ConnectionString = FSCD_SQLConnectionString
FSCD_SQLConnection.Open
FSCD_SQLCommand = "SELECT * FROM " & FSCD_MYSQL_Table
Set FSCD_Recordset = New ADODB.Recordset
FSCD_Recordset.Open FSCD_SQLCommand, FSCD_SQLConnection
FSCD_Recordset.MoveFirst
While Not FSCD_Recordset.EOF
MsgBox FSCD_Recordset.Fields("mező1").Value
MsgBox FSCD_Recordset.Fields("mező2").Value
FSCD_Recordset.MoveNext
Wend
FSCD_Recordset.Close
FSCD_SQLConnection.Close
Exit Sub
FSCD_ErrorHandler:
MsgBox "Error:" & Err.Description, vbCritical, "Fire/SOUL/CD"
End SubFire.
-
#5810
Fire/SOUL/CD
félisten
Cuci3
#5808
Hali!
Sajnos a Pascal vagy C/CPP-ban megszokott Continue utasítás itt nem létezik, helyette a Goto utasítást kell bevetni.
(az Exit For/Exit Do egyenértékű a Break Pascal vagy C/CPP utasítással, az Exit For kilép a For ciklusból, míg az Exit Do, a Do-Loop ciklust szakítja meg.)Példaprogi
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
j = 0
For i = 1 To ThisWorkbook.Worksheets.Count
If ThisWorkbook.Worksheets(i).Name = "Munka5" Then GoTo label001
j = j + 1
label001:
Next
MsgBox (j)
End SubFire.
-
Cuci3
tag
Annyira iszonyítos a hallgatás, hogy meg kell szakítanom egy kérdéssel:
Van egy ciklusom, ami végiglépked az összes munkalapon. A cikluson belül van egy elágazásom, ami megvizsgálja a munkalap nevét. Ha a munkalap neve Ellenőrzés, akkor a következő lapra kellene ugrani. Kérdés, hogy oldom ezt meg. Van-e olyan sor, ami a következő For-ba ugrasztja a progit - lentebb a program részlete. Goto-ra én is gondoltam, de az mégsem lenne annyira jó.For Each lap In Workbooks(valtozo).Worksheets
If lap.Name = el Then
Ide kellene valami next lap, vagy ilyesmi.
Else
End If
Next -
gsc73
aktív tag
válasz
Delila_1
#5782
üzenetére
Sziasztok!
Közeledünk a tökéleteshez….
Az elválasztó karakter problémaköréből adódó nehézségeket sikerült megoldanom.
Detektálásért köszönet Delila_1 –nek…………
(On Error Goto….)
Szétválasztásért köszönet Cuci3-nak………… (Adatok/Szövegből oszlopok)
Makró rögzítés. Kis alakítás, és működik is, örül, boldog………Egy kicsit más kérdés (ez már csak olyan szépítés):
A mostani personal.xlsb modul szerkezete az alábbiak szerint néz ki:Sub egyes_verzio()
'valami 1
kozos
End Sub
Sub kettes_verzio()
'valami 2
kozos
End Sub
Sub kozos()
'közös dolgok
End SubMivel a közös rész a legnagyobb (90%-a az egésznek), így logikusnak tűnt, hogy szubrutinszerűen meghívogatom, ami sok-sok egyéb előnnyel is jár. Ebben az esetben a futtatható makrók listájában 3 sor jelenik meg: egyes_verzio/kettes_verzio/kozos. Természetesen a kozos rész nem működik helyesen önmagában. El lehet azt rejteni valahogy? (hide)
Üdv: g.
-
Delila_1
veterán
Más módszerrel:
Sub Keres_1()
v% = InputBox("Kérem a keresendő értéket", "Keresés")
On Error GoTo Hiba
Cells.Find(What:=v%, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
sor = Selection.Row
Rows(sor).Select
Exit Sub
Hiba:
MsgBox "Nincs ilyen érték"
End Sub -
#4675
Delila_1
veterán
Fehér Mancs
#4674
Delila_1
veterán
válasz
Fehér Mancs
#4674
üzenetére
Nagyon jó.
Tegyük hozzá, hogy ha a TermIrány 0, akkor a tartomány jobb oldalától és lentről- , 1 értéknél pedig tartomány bal oldalától és fentről keresi az első, értéket tartalmazó cellát.
Egy pici szépítés:
Az
ElsőNemÜres = CVErr(xlErrNA) sor helyett a
On Error GoTo 0: ElsőNemÜres = ""
sor nem a csúf #HIÁNYZIK értéket adja vissza, hanem üres string lesz a függvényt tartalmazó cella kimenete. -
válasz
Delila_1
#4617
üzenetére
Rájöttem, talán az a gond,hogy közben módosítottam a táblázatot. Cellákat szúrtam be.
Az emailben amit küldtél tökéletesen működik, csak azt a táblát tovább fejlesztettem..Akkor most helyesen így nézne ki a makró?
Sub rejt()
Dim lap As Variant
lap = Array("Kaschieren", "Näherei")
For ll = 0 To 1
Sheets(lap(ll)).Select
For sor = Range("G65536").End(xlUp).Row To 11 Step -1
If Cells(sor, 7) = "" Then GoTo Köv
If Cells(sor, 7) = 0 Then
Range("G" & sor).Select
Selection.EntireRow.Hidden = True
End If
Köv:
Next
Next
End SubSub felfed()
Dim lap As Variant
lap = Array("Kaschieren", "Näherei")
For L = 0 To 1
Sheets(lap(L)).Select
Rows("11:100").Select
Selection.EntireRow.Hidden = False
Range("C1" & sor).Select
Next
End SubA G oszlop 11-es sorától kellene elrejteni, vagy felfedni.
Helyesen módosítottam?
Vagy a felfeden még kell alakítani? -
Delila_1
veterán
Két lapról van szó, ahol az adatok a 11. sorban kezdődnek, és az itt-ott 0-t tartalmazó oszlop a G.
Sub rejt()
Dim lap As Variant
lap = Array("Kaschieren", "Näherei")
For laap = 0 To 1
Sheets(lap(laap)).Select
For sor = Range("G65536").End(xlUp).Row To 11 Step -1
If Cells(sor, 7) = "" Then GoTo Köv
If Cells(sor, 7) = 0 Then
Range("G" & sor).Select
Selection.EntireRow.Hidden = True
End If
Köv:
Next
Next
End SubA range("G" & sor).select helyett először rows(sor & ":" & sor).select-et írtam. Akkor az volt a baj, hogy az egyik oszlopban lévő összevonások (merge) miatt több sort jelölt-, és rejtett el.
-
#4092
Fire/SOUL/CD
félisten
Oly
#4091
Hali!
Na így már tiszta, mit is szerettél volna elérni.
Munkafüzet1 - Munka1 (Code)
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo errorhandling
xstr = LCase(Range("B2"))
Pos = InStr(1, xstr, ".jpg", vbTextCompare)
If (Pos > 0) Then
Image1.PictureSizeMode = fmPictureSizeModeStretch
Image1.Picture = LoadPicture(xstr)
End If
Exit Sub
errorhandling: MsgBox ("FileOpen ERROR!")
End SubNa, asszem ez lesz az
Ha nem a B2-ben lesz az adat akkor egyszerűen módosítsd a makróban, egy helyen kell.Fire.
-
#4088
Fire/SOUL/CD
félisten
Oly
#4087
Hali!
Persze, de bent is van a kódban. Ha rálépsz az adott cellára, amiben a kép elérése van akkor egyből betölti(már ha valóban létező képről van szó). Próbáld ki. A gombos megoldást csak érdekességnek szántam. Ha nem kell akkor töröld ki a makróból a commandbutton1_Click() metódust, meg persze töröld a gombot is.
Pár módosítást eszközöltem, mert a korábbi verzió mindig megpróbál betölteni egy képet, ha az adott cella nem üres. Ez zavaró lehet hiszen ha egy cellában szám vagy szöveg van és az nem egy kép elérési útvonala, akkor hibát dob. Ez a javított kód.Private Sub CommandButton1_Click()
JPGFile = Application.GetOpenFilename("JPG files,*.jpg", , "Select picture...", , False)
If JPGFile <> False Then
Range("B2") = JPGFile
Image1.PictureSizeMode = fmPictureSizeModeStretch
Image1.Picture = LoadPicture(JPGFile)
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo errorhandling
xstr = LCase(Target)
Pos = InStr(1, xstr, ".jpg", vbTextCompare)
If (Target.Cells.Count = 1) And (Pos > 0) Then
Range("B2") = Target
Image1.PictureSizeMode = fmPictureSizeModeStretch
Image1.Picture = LoadPicture(Target)
End If
Exit Sub
errorhandling: MsgBox ("Multi Cells Selection found or FileOpen ERROR!")
End SubFire.
-
#4086
Fire/SOUL/CD
félisten
Oly
#4084
Hali!
Nos, a kért megoldáson kívűl még egy más módszert is beleraktam, érdekességként. A képet azért mellékeltem, nehogy más objektumot használj, hanem sima Image-t.
Munkafüzet1 - Munka1(Code)
Private Sub CommandButton1_Click()
JPGFile = Application.GetOpenFilename("JPG files,*.jpg", , "Select picture...", , False)
If JPGFile <> False Then
Range("B2") = JPGFile
Image1.PictureSizeMode = fmPictureSizeModeStretch
Image1.Picture = LoadPicture(JPGFile)
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo errorhandling
If (Target.Cells.Count = 1) And Target <> "" Then
Range("B2") = Target
Image1.PictureSizeMode = fmPictureSizeModeStretch
Image1.Picture = LoadPicture(Target)
End If
Exit Sub
errorhandling: MsgBox ("Multi Cells Selection found or FileOpen ERROR!")
End SubFire.
-
Balinov
titán
Sziaszto, Excel 2007 (angol) eseten futottam bele egy erdekes, am annal idegesitobb problemaban.
Dolgozok napi szinten egy cirka 2500 sorbol allo ill. AN oszlopig kiterjedo Oraclebol exportalt excel tablaval. formazas semmi kulonos, egy auto filter van az oszlopnevekhez, meg a fejadatok vannak szinnel kiemelve. A gondom az, hogy pl. egy vevore leszukitem a forrast (legyen a neve A), kijelolom oszlopcimmel egyutt es egy Crtl+N-t bokve uj fileba akarnam copy-paste-vel beilleszteni. Na ilyet rendkivul gyakran kell csinalni. Nem regota raktak fel a cegnel az Office 2003 helyett a 2007-et. Nagyon sokaig mukodott is, am egyszercsak azt kezdte el csinalni, hogy Crtl+V utan az uj munkafuzetben csak a kijeloles merete (x*y oszlop es sor) latszik, de a forras munkafuzet cellainak az erteke nem kerul at az ujba.
Igy csinalom: Szurovel kivalasztom XYZ vevot. Kijelolom az adatokat (pl. A1-tol X16ig) egerrel. Crtl+C masol. Uj munkafuzet megnyit, goto A1 cella. Crtl+V beilleszt.
Rohadjon meg, most hogy irom a postot ujbol megprobalom. Ha az oszlopcimes sort (C sor) kijelom, kopipeszt megy. Ha filter nelkul kijelolok kb. 50 sort oszlopfejlecestol, megy. Ha raszurok xzy vevore, kijelolom, kopipeszt uj munkafuzetbe, nem megy. Hat
Ilyet nem ertem. Mi lehet a gond?1db makro van csak, de az is csak a formazast csinalja meg nekem, hogy kb 1 kepernyo szelessegben a legfontosabb adatokat tartalmazo oszlopok latszodjanak.
Valakinek tippe, otlete?
Koszi
Balinov -
Delila_1
veterán
Mondták, igaz, akkor istennőt mondtak. Köszönöm. Itt a javított kiadás hibakezeléssel.
Sub Adatok()
utvonal = "E:\Eadat\"
sor = 2
Do While Cells(sor, 1) <> ""
fnev = Cells(sor, 1) & ".xls"
funev = utvonal & Cells(sor, 1)
On Error GoTo hiba
Workbooks.Open Filename:=funev
If tal = 0 Then
ActiveWindow.ActivatePrevious
Cells(sor, 2).Select
ActiveCell.Formula = "=INDIRECT(""[" & fnev & "]Munka1!B3"")"
Cells(sor, 3).Select
ActiveCell.Formula = "=INDIRECT(""[" & fnev & "]Munka1!C6"")"
Cells(sor, 4).Select
ActiveCell.Formula = "=SUM(INDIRECT(""[" & fnev & "]Munka1!E1:E7""))"
Range(Cells(sor, 2), Cells(sor, 4)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
ActiveWindow.ActivateNext
ActiveWindow.Close
Else
Cells(sor, 2) = "Nem létező file"
End If
tal = 0
sor = sor + 1
Loop
Exit Sub
hiba:
Err = 0
tal = 1
Resume Next
End Sub -
#2099
matekmatika
tag
ssrobi
#2097
matekmatika
tag
Persze a követkaző formula kicsit elegánsabb. Nem csak azért, mert van benne egy hibakezelés is arra az esetre, ha nem lenne nyitva a másolandó adatokat tartalmazó munkafüzet, hanem mert csak
Sub akarmi()
On Error GoTo ErrorHandler
Workbooks(''munkafüzet1.xls'').Activate
Columns(''A:A'').Select
Selection.Copy
Workbooks(''munkafüzet2.xls'').Activate
Cells(1, 1).Select
ActiveSheet.Paste
Exit Sub
ErrorHandler:
Workbooks.Open Filename:=''munkafüzet1.xls''
End Sub
![;]](http://cdn.rios.hu/dl/s/v1.gif)
(a többiről a kódodban nem is beszélve)
Új hozzászólás Aktív témák
Hirdetés
Fferi50- Milyen program, ami...?
- Brutál akkuval érkeztek az Ulefone X16 modellek
- Formula-1
- Vélemény: nem úgy tűnik, de Lip-Bu Tan most menti meg az Intelt
- Xbox Series X|S
- Milyen autót vegyek?
- LG V30 - vezércsel
- HiFi műszaki szemmel - sztereó hangrendszerek
- A fociról könnyedén, egy baráti társaságban
- NVIDIA GeForce RTX 5080 / 5090 (GB203 / 202)
- További aktív témák...
- Microsoft licencek KIVÉTELES ÁRON AZONNAL - UTALÁSSAL IS AUTOMATIKUS KÉZBESÍTÉS - Windows és Office
- 27%-OS ÁFÁS SZÁMLA I Jogtiszta Microsoft digitális és fizikai termékek I DIGITALKEYZ.COM
- ROBUX ÁRON ALUL - VÁSÁROLJ ROBLOX ROBUXOT MÉG MA, ELKÉPESZTŐ KEDVEZMÉNNYEL (Bármilyen platformra)
- Kaspersky, McAfee, Norton, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Sea of Thieves Premium Edition és Egyéb Játékkulcsok.
- Honor Magic7 Lite 8/512GB, Kártyafüggetlen
- Hp Prodesk 600 G3/ G5/ G6 SFF-MT / i5 8-9-10 gen, Hp EliteDesk 800 G4 / Win11- Számla, garancia
- AKCIÓ! Apple Macbook Pro 15" 2018 i9 9850HK 32GB 500GB 560X 4GB garanciával hibátlan működéssel
- ÚJ Apple Macbook Air 15,3 M4 10C CPU/10C GPU/16GB/256GB - Ezüst -(2025) - 3 év gari - MAGYAR
- Csere-Beszámítás! RTX Számítógép játékra! I7 6700K / 32GB DDR4 / RTX 2060 / 500GB SSD
Állásajánlatok
Cég: Promenade Publishing House Kft.
Város: Budapest
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest