-
Fototrend
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
Az A1 képlete, amit jobbra húzhatsz:
=INDIREKT(KARAKTER(OSZLOP()+OSZLOP()-1+64)&2)
A -1+64-et összevonhatod, csak a jobb érthetőség kedvéért írtam külön. A +64 onnan jön, hogy az "A" ASCII értéke (karakter kódja) 65.
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
félisten
-
Delila_1
Topikgazda
Próba nélkül:
=INDIREKT("A"&KARAKTER(OSZLOP()+OSZLOP()-1+64)&2)
Itt észnél kell lenned, mert a második sor hivatkozott cellája már akkor átvált AA-ra, mikor az első sor még bőven benne van a sima ABC-ben. Valószínűleg meg lehetne oldani HA függvénnyel a váltást.
[ 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.
-
Delila_1
Topikgazda
-
Delila_1
Topikgazda
Az AA1 képlete a -52-n kívül is változik.
=INDIREKT("B"&KARAKTER(OSZLOP()+OSZLOP()-1+64-52)&2)
13 oszloponként változik a képlet, figyelj rá.
Az AN1 =INDIREKT("C"&KARAKTER(OSZLOP()+OSZLOP()-1+64-78)&2)[ 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.
-
Delila_1
Topikgazda
Ha erre gondoltál,
ez a makró állítja elő:
Sub megj()
For Each CV In Range("A2:A11")
név = CV
If Weekday(név, 2) = 1 Then m = Date - 3 Else m = Date - 1
név = Year(m) & "." & Right("0" & Month(m), 2) & "." & Right("0" & Day(m), 2)
On Error Resume Next
CV.AddComment
CV.Comment.Text Text:=név
CV.Select
ActiveCell.Comment.Visible = True
CV.Comment.Shape.Select True
With Selection.ShapeRange
.ScaleWidth 0.48, msoFalse, msoScaleFromTopLeft
.ScaleHeight 0.23, msoFalse, msoScaleFromTopLeft
End With
Next
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
Ráállsz a cellára, Képletek, Képletvizsgálat, Elődök- vagy Utódok mutatása.
Ha másik lapon-füzetben van az előd, vagy utód, egy kis táblázat kinézetű ikon jelenik meg, szaggatott vonallal. Erre a szaggatottra duplán klikkelsz, és megjelenik a hivatkozás helye.
A hivatkozást kijelölve, okézva az adott helyre ugrik a fókusz.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
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 SubProgramozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
-
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 FunctionBámulatos hol tart már a tudomány!
-
Delila_1
Topikgazda
A D:\valami\ könyvtárban található *.xls fájlokat nyitja meg, és az indító füzet (ebbe írd be a makrót) lapjai mögé másolja a behívott fájlok aktuális lapját, végül az indító fájlt lementi az eredeti helyére. Ez a fájl NE legyen azonos könyvtárban a behívandókkal.
Sub Osszevon()
Const utvonal = "D:\valami\"
Dim FN As String, WBN As String, lsz As Integer
Application.DisplayAlerts = False
WBN = ActiveWorkbook.Name
ChDir utvonal
FN = Dir(utvonal & "*.xls", vbNormal)
Do
lsz = Sheets.Count
If FN <> "." And FN <> ".." Then
Workbooks.Open Filename:=FN
ActiveSheet.Copy After:=Workbooks(WBN).Sheets(lsz)
Windows(FN).Activate
ActiveWindow.Close 'bezárás
End If
FN = Dir()
Loop Until FN = ""
ActiveWorkbook.Save
Application.DisplayAlerts = True
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
Így más a leányzó fekvése.
Sub Osszevon()
Const utvonal = "D:\valami\"
Dim FN As String, WB As Workbook, lsz As Integer
Application.DisplayAlerts = False
Set WB = ActiveWorkbook
ChDir utvonal
FN = Dir(utvonal & "*.xls", vbNormal)
Do
If FN <> "." And FN <> ".." Then
Workbooks.Open Filename:=FN
lsz = Sheets.Count
WB.Activate
ActiveSheet.Copy After:=Workbooks(FN).Sheets(lsz)
ActiveWorkbook.Save
ActiveWindow.Close
End If
FN = Dir()
Loop Until FN = ""
Application.DisplayAlerts = True
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.
-
-
poffsoft
addikt
Option Explicit
Sub lapok()
Dim sorIN%, WSIN As Worksheet
Set WSIN = Sheets(ActiveSheet.Index)
sorIN% = WSIN.Cells(Rows.Count, "A").End(xlUp).Row
Do While sorIN% > 0
If Not (WorksheetExists(WSIN.Cells(sorIN%, 1))) Then
Sheets.Add(After:=WSIN).Name = WSIN.Cells(sorIN%, 1)
Sheets(WSIN.Cells(sorIN%, 1).Value).Range("A1") = WSIN.Cells(sorIN%, 1)
End If
sorIN% = sorIN% - 1
Loop
WSIN.Select
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
Dim Sht As Worksheet
WorksheetExists = False
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name = WorksheetName Then WorksheetExists = True
Next Sht
End Function[ Szerkesztve ]
-
poffsoft
addikt
nem excel korlát, én hibáztam.
Nem gondoltam, hogy sima szám is lehet a név...
Option Explicit
Sub lapok()
Dim sorIN%, WSIN As Worksheet
Set WSIN = Sheets(ActiveSheet.Index)
sorIN% = WSIN.Cells(Rows.Count, "A").End(xlUp).Row
Do While sorIN% > 0
If Not (WorksheetExists(WSIN.Cells(sorIN%, 1))) Then
Sheets.Add(After:=WSIN).Name = "" & WSIN.Cells(sorIN%, 1)
Sheets("" & WSIN.Cells(sorIN%, 1)).Range("A1") = WSIN.Cells(sorIN%, 1)
End If
sorIN% = sorIN% - 1
Loop
WSIN.Select
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
Dim Sht As Worksheet
WorksheetExists = False
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name = WorksheetName Then WorksheetExists = True
Next Sht
End Functionnem sokat kellet változtatni rajta
amúgy nincs mit
[ Szerkesztve ]
[ Szerkesztve ]
-
Delila_1
Topikgazda
Egy másik megoldás:
Sub UjLapok()
Dim sor%, WSKezd As Worksheet
Set WSKezd = Sheets(1)
sor% = 1
Do While WSKezd.Cells(sor, 1) <> ""
Sheets.Add(After:=Sheets(sor%)).Name = WSKezd.Cells(sor%, 1)
ActiveSheet.Cells(1) = WSKezd.Cells(sor%, 1)
sor% = sor% + 1
Loop
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.
-
-
zhari
csendes tag
Sziasztok!
Abban kérném a segítségeteket, hogy a hivatkozott jól működő email küldő makrót be lehet állítani, hogy az Outlookba felcsatolt két postafiókból melyikből küldje ki. Azaz melyik postafiók legyen az email küldője. Sajnos ha alapértelmezett fióknak veszem a kívánt fiókot (Outlookban) akkor nem működik.
Remélem érthető volt a kínom. -
Mutt
aktív tag
Hello,
...megnézni munkafüzetek füleinek a színét és egy meghatározott munkafüzet azonos nevű munkafüzeteinek a fül színét beszínezi...
Ezt tudod használni.
Sub Colorize()
Dim arrayColor() 'lapnev és lapszín megnevezése
Dim wbActual As Workbook
Dim c As Long, i As Long
Dim fileName As String
Const refFile As String = "c:\reference.xlsm" 'referencia fájl neve helye
Const filePath As String = "c:\list\" 'módosítandó fájlok helye
Const fileExt As String = "*.xls" 'módosítando fájlok kitejesztése
'a referencia alapján megjegyezzük a lapneveket és színeket
Set wbActual = Workbooks.Open(refFile)
ReDim arrayColor(1 To 2, 1 To wbActual.Sheets.Count)
With wbActual
For c = 1 To .Sheets.Count
arrayColor(1, c) = .Sheets(c).Name
arrayColor(2, c) = .Sheets(c).Tab.Color
Next c
End With
wbActual.Close
'végeztünk a referencia fájllal
fileName = Dir(filePath & fileExt, vbNormal)
'végigmegyünk a mappában lévő fájlokon
Do While Len(fileName) > 0
Set wbActual = Workbooks.Open(filePath & fileName)
With wbActual
For c = 1 To .Sheets.Count
For i = 1 To UBound(arrayColor, 2)
'ahol a lap neve egyezik ott szinezünk
If .Sheets(c).Name = arrayColor(1, i) Then
.Sheets(c).Tab.Color = arrayColor(2, i)
End If
Next i
Next c
End With
wbActual.Save
wbActual.Close
fileName = Dir
Loop
End Subüdv.
A tanácsaimat ingyen adom. Ha nem tetszik, akkor kérlek ne kritizáld! / https://github.com/viszi/codes/tree/master/Excel
-
kekec@
csendes tag
Szia!
Hú ha ez kicsit már bonyolult nekem...
Na eddig eljutottam:Sub Makró11()
'
' Makró11 Makró
''
ChDir "C:\Documents\Hibabejelentő\Jelentések"
ment = utvonal & fajlnev & "Valami " & Format(Now, "yyyy.mm.dd") & ".xls"
ActiveWorkbook.SaveAs ment
'
' mail Makró
''
Range("B11").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=TrueEnd Sub
Most már az is jó hogy, máshova menti (az eredetit békén hagyva ) Dátummal és megfelelő névvel nevezve.
Outlook indul ha ráklikkelek a mailcímre. Na innen kezdődnek a gondjaim.
Csatolnia kellene a helyes-kitöltött xls-t, tárgymező kitöltésével egy makrónak.
Hogyan lehetne egyszerűen megoldani? -
Delila_1
Topikgazda
Ezt tudtommal csak makró segítségével tudod megoldani.
A példámban az adatok az A1 cellában kezdődnek.
A középre rendezett cellák hátterét pirosra festi.Sub Kozepre()
Dim CV As Object
Range("A1").Select
Selection.CurrentRegion.Select
For Each CV In Selection
If Range(CV.Address).HorizontalAlignment = xlCenter Then _
Range(CV.Address).Interior.ColorIndex = 3
Next
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.
-
lappy
őstag
Szia!
Az első részre a megoldás:
Sub Open_My_Files()
Dim MyFile As String
MyPath = " M:\Access Files\ "
MyFile = Dir(MyPath)
Do While MyFile <> ""
If MyFile Like "*.xls" Then
Workbooks.Open MyPath & MyFile
Sheets(1).Select
Range("C3") = 6
ActiveWorkbook.Close True
End If
MyFile = Dir
Loop
End SubA második részre meg szerintem találsz itt is a fórumon leírást, a kettőt már csak össze kell tenni és kész.
Bámulatos hol tart már a tudomány!
-
Delila_1
Topikgazda
Nem tudtam megírni, egy régi kedves barátom segített ki.
A teszt makróban a .StartFolder = "F:\" sorban írd át a meghajtó nevét a sajátodra, majd a ciklusban a jelzett részbe tedd be a másolást, és a megnyitott fájl bezárását. Ezt makrót kell indítanod. Bekéri a keresendő fájlok nevének azt a részét, ami közös, a példád szerint ez valami. A státuszsorban megjelennek a mappák, almappák, ahol a valami kezdetű fájlneveket keresi.
Public Type TFindFile
StartFolder As String
FileName As String
Extension As String
Findings() As String
ErrorCount As Long
End TypeFunction FindFile(Args As TFindFile) As Boolean
Dim Folders() As String, CurrentFolder As String, FolderLevel As Long
Dim FN As String, LookUpName As String
Dim i As Long, Maxi As Long, Mini As Long, FileFound As Boolean
Dim Rng As Range
With Args
ChDrive Left(.StartFolder, 1)
If Right(.StartFolder, 1) <> "\" Then .StartFolder = .StartFolder & "\"
ReDim Folders(1)
Folders(1) = .StartFolder
FolderLevel = UBound(Split(.StartFolder, "\"))
LookUpName = .FileName & "." & .Extension
End With
ReDim Args.Findings(0)
Mini = 1
On Error GoTo hiba
Do
Maxi = UBound(Folders)
For i = Mini To Maxi
FN = Dir(Folders(i) & LookUpName, vbNormal)
While Not FN = ""
FileFound = True
ReDim Preserve Args.Findings(UBound(Args.Findings) + 1)
Args.Findings(UBound(Args.Findings)) = Folders(i) & FN
FN = Dir()
Wend
If UBound(Split(Folders(i), "\")) = FolderLevel Then
FN = Dir(Folders(i) & "*.*", vbDirectory)
While Not FN = ""
If (FN <> ".") And (FN <> "..") Then
If (GetAttr(Folders(i) & FN) And vbDirectory) <> 0 Then
FN = Folders(i) & FN & "\"
ReDim Preserve Folders(UBound(Folders) + 1)
Folders(UBound(Folders)) = FN
Application.StatusBar = FN
End If
End If
FN = Dir()
Wend
End If
DoEvents
Next
Mini = Maxi
FolderLevel = FolderLevel + 1
Loop Until Maxi = UBound(Folders)
If FileFound Then FindFile = True
Application.StatusBar = False
Exit Function
hiba:
Set Rng = Sheets("Hibák").Range("A" & Rows.Count).End(xlUp).Offset(1)
With Rng
.Value = Folders(i)
.Offset(, 1) = FN
.Offset(, 2) = Err.Description
.Offset(, 3) = Err.Number
End With
Args.ErrorCount = Args.ErrorCount + 1
Resume Next
End FunctionSub teszt()
Dim Args As TFindFile
Dim Siker As Boolean, i As Long
With Args
'**************** itt a saját meghajtód nevét írd be! *******
.StartFolder = "F:\"
'****************************************************************
.FileName = InputBox("fájlnév vagy része") & "*"
.Extension = "xlsx"
End With
Siker = FindFile(Args:=Args)
If Siker Then
For i = 1 To UBound(Args.Findings)
Workbooks.Open FileName:=Args.Findings(i)
'****************************************************************
' ide jön a másolás, majd a behívott fájl bezárása
'****************************************************************
Next
Else
MsgBox "Nincs találat."
End If
If Args.ErrorCount > 0 Then
MsgBox Args.ErrorCount & " probléma merült fel, lásd Hibák munkalap."
End If
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
Küldöm a másolással, és értékbeillesztéssel kiegészített teszt makrót. Írd át a meghajtó betűjelét!
Sub teszt()
Dim Args As TFindFile, usor As Long, WS As Worksheet
Dim Siker As Boolean, i As Long
With Args
'**************** itt a saját meghajtód nevét írd be! *******
.StartFolder = "F:\"
'****************************************************************
.FileName = InputBox("fájlnév vagy része") & "*"
.Extension = "xlsx"
End With
Siker = FindFile(Args:=Args)
Set WS = ActiveWorkbook.Sheets("Munka1")
If Siker Then
For i = 1 To UBound(Args.Findings)
usor = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
Workbooks.Open FileName:=Args.Findings(i)
Range("Munka1!A1:L7").Copy
WS.Range("A" & usor).PasteSpecial xlPasteValues
ActiveWorkbook.Close
Next
Else
MsgBox "Nincs találat."
End If
If Args.ErrorCount > 0 Then
MsgBox Args.ErrorCount & " probléma merült fel, lásd Hibák munkalap."
End If
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
-
Delila_1
Topikgazda
Ennél az A:D tartományból számolsz valamit a kalkulátor lapon. Ha úgy írnám, ahogy mondtad, az eredmény minden sorból a lista lap E2 és F2 cellájába kerülne, felülírva az előző adatokat. A másolást az E2 és F2 cellába tettem első esetben, a továbbiakat rendben ezek alá.
Sub Valami()
Dim sor As Long, WS As Worksheet, sor1 As Long
Set WS = Sheets("kalkulátor")
sor = 1: sor1 = 2
Sheets("lista").Activate
Do While Cells(sor, "A") <> ""
Range("A" & sor & ":D" & sor).Copy
WS.Range("B2").PasteSpecial Paste:=xlPasteAll, Transpose:=True
WS.Range("O6").Copy
Range("E" & sor1).PasteSpecial xlPasteValues
WS.Range("R6").Copy
Range("F" & sor1).PasteSpecial xlPasteValues
sor = sor + 1: sor1 = sor1 + 1
Loop
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.
-
Új hozzászólás Aktív témák
- Bemutatta első Snapdragon X-re épülő notebookját az ASUS
- Fortnite - Battle Royale & Save the World (PC, XO, PS4, Switch, Mobil)
- Vezetékes FEJhallgatók
- Politika
- Vodafone otthoni szolgáltatások (TV, internet, telefon)
- Sorozatok
- eMAG/edigital vélemények - tapasztalatok
- Óvodások homokozója
- Milyen routert?
- Xbox Series X|S
- További aktív témák...
Állásajánlatok
Cég: Ozeki Kft.
Város: Debrecen
Cég: Ozeki Kft.
Város: Debrecen