Hogyan nevezhetjük át az összes képnevet egy mappában az Excel cellalistája szerint?
Próbálta már átnevezni a képeket a munkalapon lévő cellák listája szerint? Ha igen, van-e trükkje a munka gyors kezelésére anélkül, hogy egyesével átnevezné őket? Ebben a cikkben két VBA kódot mutatok be, hogy gyorsan kezelhessem ezt a munkát az Excelben.
Nevezze át az összes képnevet egy mappában
Nevezze át az összes képnevet egy mappában
A megadott mappában található összes kép nevének átnevezéséhez először az eredeti neveket kell felsorolni a lapba.
1. nyomja meg Alt + F11 gombok a Microsoft Visual Basic for Applications ablak.
2. kettyenés betétlap > Modulok és illessze be a kód alatt a szkriptbe.
VBA: Kap egy mappa képnevét
Sub PictureNametoExcel()
'UpdatebyExtendoffice201709027
Dim I As Long
Dim xRg As Range
Dim xAddress As String
Dim xFileName As String
Dim xFileDlg As FileDialog
Dim xFileDlgItem As Variant
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Select a cell to place name list:", "KuTools For Excel", xAddress, , , , , 8)
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xRg = xRg(1)
xRg.Value = "Picture Name"
With xRg.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
End With
xRg.EntireColumn.AutoFit
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
I = 1
If xFileDlg.Show = -1 Then
xFileDlgItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xFileDlgItem & "\")
Do While xFileName <> ""
If InStr(1, xFileName, ".jpg") + InStr(1, xFileName, ".png") + InStr(1, xFileName, ".img") + InStr(1, xFileName, ".gif") + InStr(1, xFileName, ".ioc") + InStr(1, xFileName, ".bmp") > 0 Then
xRg.Offset(I).Value = xFileDlgItem & "\" & xFileName
I = I + 1
End If
xFileName = Dir
Loop
End If
Application.ScreenUpdating = True
End Sub
3. nyomja meg F5 gombot a kód futtatásához, és megjelenik egy párbeszédpanel, amely emlékezteti Önt, hogy válasszon egy cellát a névlista kiadásához. Lásd a képernyőképet:
4. kettyenés OK és válassza ki a megadott mappát, amelynek képneveit fel kell sorolnia az aktuális munkalapra. Lásd a képernyőképet:
5. kettyenés OK. A képnevek fel vannak tüntetve az aktív lapon.
Ezután átnevezheti a képeket.
1. nyomja meg Alt + F11 gombok a Microsoft Visual Basic for Applications ablak.
2. kettyenés betétlap > Modulok és illessze be a kód alatt a szkriptbe.
VBA: Képek átnevezése
Sub RenameFile()
'UpdatebyExtendoffice20170927
Dim I As Long
Dim xLastRow As Long
Dim xAddress As String
Dim xRgS, xRgD As Range
Dim xNumLeft, xNumRight As Long
Dim xOldName, xNewName As String
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRgS = Application.InputBox("Select Original Names(Single Column):", "KuTools For Excel", xAddress, , , , , 8)
If xRgS Is Nothing Then Exit Sub
Set xRgD = Application.InputBox("Select New Names(Single Column):", "KuTools For Excel", , , , , , 8)
If xRgD Is Nothing Then Exit Sub
Application.ScreenUpdating = False
xLastRow = xRgS.Rows.Count
Set xRgS = xRgS(1)
Set xRgD = xRgD(1)
For I = 1 To xLastRow
xOldName = xRgS.Offset(I - 1).Value
xNumLeft = InStrRev(xOldName, "\")
xNumRight = InStrRev(xOldName, ".")
xNewName = xRgD.Offset(I - 1).Value
If xNewName <> "" Then
xNewName = Left(xOldName, xNumLeft) & xNewName & Mid(xOldName, xNumRight)
Name xOldName As xNewName
End If
Next
MsgBox "Congratulations! You have successfully renamed all the files", vbInformation, "KuTools For Excel"
Application.ScreenUpdating = True
End Sub3. nyomja meg F5 gombot a kód futtatásához, és megjelenik egy párbeszédpanel, amely emlékezteti Önt a cserélni kívánt eredeti képnevek kiválasztására. Lásd a képernyőképet:
4. kettyenés OK, és a második párbeszédpanelen válassza ki a képnevek helyébe lépő új neveket. Lásd a képernyőképet:
5. kettyenés OK, megjelenik egy párbeszédpanel, amely emlékeztet arra, hogy a képneveket sikeresen kicserélték.
6. Kattintson az OK gombra, és a képneveket a lap cellái helyettesítik.
 |
 |
 |
Relatív cikkek:
A legjobb irodai hatékonyságnövelő eszközök
Töltsd fel Excel-készségeidet a Kutools for Excel segítségével, és tapasztald meg a még soha nem látott hatékonyságot. A Kutools for Excel több mint 300 speciális funkciót kínál a termelékenység fokozásához és az időmegtakarításhoz. Kattintson ide, hogy megszerezze a leginkább szükséges funkciót...
Az Office lap füles felületet hoz az Office-ba, és sokkal könnyebbé teszi a munkáját
- Füles szerkesztés és olvasás engedélyezése Wordben, Excelben és PowerPointban, Publisher, Access, Visio és Project.
- Több dokumentum megnyitása és létrehozása ugyanazon ablak új lapjain, mint új ablakokban.
- 50% -kal növeli a termelékenységet, és naponta több száz kattintással csökkenti az egér kattintását!
