Function ЗаменитьБукву$(s$) With CreateObject("scriptcontrol") .Language = "JScript" ЗаменитьБукву = .eval("'" & s & "'.replace(/(?:^|\b)([a-z])/gi, " & _ "function(a) { return a.toUpperCase(); })") End With End Function
[/vba]
и я того же мнения [vba]
Код
Function ЗаменитьБукву$(s$) With CreateObject("scriptcontrol") .Language = "JScript" ЗаменитьБукву = .eval("'" & s & "'.replace(/(?:^|\b)([a-z])/gi, " & _ "function(a) { return a.toUpperCase(); })") End With End Function
Private Sub TextBox1_Change() If Not IsNumeric(TextBox1) Or Val(TextBox1) <= 0 Then Exit Sub Лист2.[C6:C8] = Application.Transpose(Лист1.[B4:D4].Offset(TextBox1)) End Sub
[/vba]
Здравствуйте. Можно как-то так [vba]
Код
Private Sub TextBox1_Change() If Not IsNumeric(TextBox1) Or Val(TextBox1) <= 0 Then Exit Sub Лист2.[C6:C8] = Application.Transpose(Лист1.[B4:D4].Offset(TextBox1)) End Sub
Sub vvv() Dim v As Variant On Error Resume Next With Selection For Each v In Array("авто*", "Метла", "61??", ChrW(157)) .Replace v, "=xfd1", xlWhole, searchformat:=False Intersect([xfd1].Dependents, .Cells).Delete xlUp Next End With End Sub
для начала нужно выделить ячейку с этим символом, в VBE в окно Immediate(если его нету, нажать Ctrl+G для отобраения) ввести ?ascw(selection) и нажать Enter Полученное число вставить в функцию ChwW() вместо 157
[vba]
Код
Sub vvv() Dim v As Variant On Error Resume Next With Selection For Each v In Array("авто*", "Метла", "61??", ChrW(157)) .Replace v, "=xfd1", xlWhole, searchformat:=False Intersect([xfd1].Dependents, .Cells).Delete xlUp Next End With End Sub
для начала нужно выделить ячейку с этим символом, в VBE в окно Immediate(если его нету, нажать Ctrl+G для отобраения) ввести ?ascw(selection) и нажать Enter Полученное число вставить в функцию ChwW() вместо 157krosav4ig
Sub Макрос1() Application.ScreenUpdating = False Dim sh As Shape On Error Resume Next Set sh = ActiveSheet.Shapes("Вставленный") Do Until sh Is Nothing sh.Delete Set sh = Nothing Set sh = ActiveSheet.Shapes("Вставленный") Loop End Sub
[/vba]
или так [vba]
Код
Sub Макрос1() Application.ScreenUpdating = False Dim sh As Shape On Error Resume Next Set sh = ActiveSheet.Shapes("Вставленный") Do Until sh Is Nothing sh.Delete Set sh = Nothing Set sh = ActiveSheet.Shapes("Вставленный") Loop End Sub
Sub vvv() With Selection .Replace "Автомобиль", "=xx1", xlWhole Intersect([xx1].Dependents, .Cells).Delete xlUp With .SpecialCells(xlCellTypeConstants, 1) Set r = .Find("?", , xlValues, xlWhole, Searchformat:=False) Do While Not r Is Nothing r.Formula = Format(r, "'00") Set r = .FindNext(r) Loop End With End With End Sub
[/vba]
до кучи [vba]
Код
Sub vvv() With Selection .Replace "Автомобиль", "=xx1", xlWhole Intersect([xx1].Dependents, .Cells).Delete xlUp With .SpecialCells(xlCellTypeConstants, 1) Set r = .Find("?", , xlValues, xlWhole, Searchformat:=False) Do While Not r Is Nothing r.Formula = Format(r, "'00") Set r = .FindNext(r) Loop End With End With End Sub
Ну, видимость объединения можно оставить, например, если выполнить подобный макрос, то пустых ячеек не будет, но объединение останется [vba]
Код
Sub dd() With Application .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = 0 With Sheets("Ëèñò1") .Copy Sheets(1) With .[A1].CurrentRegion .UnMerge On Error Resume Next .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" On Error GoTo 0 Sheets(1).Range(.Address).Copy .PasteSpecial xlPasteFormats Sheets(1).Delete End With End With .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1 End With End Sub
[/vba]
Ну, видимость объединения можно оставить, например, если выполнить подобный макрос, то пустых ячеек не будет, но объединение останется [vba]
Код
Sub dd() With Application .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = 0 With Sheets("Ëèñò1") .Copy Sheets(1) With .[A1].CurrentRegion .UnMerge On Error Resume Next .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" On Error GoTo 0 Sheets(1).Range(.Address).Copy .PasteSpecial xlPasteFormats Sheets(1).Delete End With End With .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1 End With End Sub
странно, у меня все нормально отрабатывает, создается 17 файлов Upd. А, вот в чем дело, я запускал макрос из VBE, для того чтобы работало, нужно переназначить макрос для фигуры на листе Rip (2)
странно, у меня все нормально отрабатывает, создается 17 файлов Upd. А, вот в чем дело, я запускал макрос из VBE, для того чтобы работало, нужно переназначить макрос для фигуры на листе Rip (2)krosav4ig
Sub Copfyiles() Const sPath1$ = "d:\layout\" Dim S$, sPath2$, sFrom$, sTo$ Dim cell As Range, r As Range, i%, j%, n sPath2 = CreateObject("Shell.Application").Namespace(0).self.path & "\" & [G2] & "\" If Dir(sPath2, 16) = "" Then MkDir sPath2 On Error Resume Next With [A2].CurrentRegion With .Offset(1, 1) Set r = .SpecialCells(xlCellTypeFormulas, 1) If r Is Nothing Then Set r = .SpecialCells(xlCellTypeConstants, 1) Else Set r = Union(r, .SpecialCells(xlCellTypeConstants, 1)) End If If r Is Nothing Then Exit Sub End With For Each cell In r.Cells S = Intersect(cell.EntireColumn, .Rows(1)) & "\" & Intersect(cell.EntireRow, .Columns(1)) & "\" sFrom = sPath1 & S sTo = sPath2 & Replace(S, "\", "_") For i = 1 To 5 For j = 1 To cell Select Case True Case i < 3 Or (j = cell And j Mod 2) FileCopy sFrom & i & ".tif", sTo & i & "-" & j & ".tif" Case (j Mod 2) = 0 FileCopy sFrom & i * 11 & ".tif", sTo & i * 11 & "-" & j \ 2 & ".tif" End Select Next Next Next End With Set r = Nothing If MsgBox("Готово!" & vbLf & "Открыть папку?", 36) = 6 Then Shell "explorer """ & sPath2 & """", 1 End Sub
[/vba]
можно так [vba]
Код
Sub Copfyiles() Const sPath1$ = "d:\layout\" Dim S$, sPath2$, sFrom$, sTo$ Dim cell As Range, r As Range, i%, j%, n sPath2 = CreateObject("Shell.Application").Namespace(0).self.path & "\" & [G2] & "\" If Dir(sPath2, 16) = "" Then MkDir sPath2 On Error Resume Next With [A2].CurrentRegion With .Offset(1, 1) Set r = .SpecialCells(xlCellTypeFormulas, 1) If r Is Nothing Then Set r = .SpecialCells(xlCellTypeConstants, 1) Else Set r = Union(r, .SpecialCells(xlCellTypeConstants, 1)) End If If r Is Nothing Then Exit Sub End With For Each cell In r.Cells S = Intersect(cell.EntireColumn, .Rows(1)) & "\" & Intersect(cell.EntireRow, .Columns(1)) & "\" sFrom = sPath1 & S sTo = sPath2 & Replace(S, "\", "_") For i = 1 To 5 For j = 1 To cell Select Case True Case i < 3 Or (j = cell And j Mod 2) FileCopy sFrom & i & ".tif", sTo & i & "-" & j & ".tif" Case (j Mod 2) = 0 FileCopy sFrom & i * 11 & ".tif", sTo & i * 11 & "-" & j \ 2 & ".tif" End Select Next Next Next End With Set r = Nothing If MsgBox("Готово!" & vbLf & "Открыть папку?", 36) = 6 Then Shell "explorer """ & sPath2 & """", 1 End Sub