Вариант с ODBC подключением таблица автоматически обновляется при изменении ячейки М2, или ПКМ по таблице>Обновить текст запроса[vba]
Код
SELECT top 10 Материал1 AS Наименование, Материал AS PLU, `Списание без НДС (Итог) (руб)` AS [Потери, руб], cdbl(replace(0&`Списание без НДС (Итог) (%)`,' %',''))/100 AS [Потери от реализации, %] FROM `Лист1$` WHERE (Материал1<>'Результат') AND (Товиерур2=?) ORDER BY `Списание без НДС (Итог) (руб)` DESC
[/vba] плюс макрос для обновления строки подключения в модуле Лист [vba]
Код
Public WithEvents QT As QueryTable Private Sub qt_BeforeRefresh(Cancel As Boolean) QT.Connection = "ODBC;DSN=Excel Files;DriverId=1046;DBQ=" & ThisWorkbook.FullName End Sub
[/vba]в ЭтаКнига[vba]
Код
Private Sub Workbook_Open() Set Лист1.QT = ThisWorkbook.Connections("запрос").Ranges(1).ListObject.QueryTable End Sub
[/vba]
Вариант с ODBC подключением таблица автоматически обновляется при изменении ячейки М2, или ПКМ по таблице>Обновить текст запроса[vba]
Код
SELECT top 10 Материал1 AS Наименование, Материал AS PLU, `Списание без НДС (Итог) (руб)` AS [Потери, руб], cdbl(replace(0&`Списание без НДС (Итог) (%)`,' %',''))/100 AS [Потери от реализации, %] FROM `Лист1$` WHERE (Материал1<>'Результат') AND (Товиерур2=?) ORDER BY `Списание без НДС (Итог) (руб)` DESC
[/vba] плюс макрос для обновления строки подключения в модуле Лист [vba]
Код
Public WithEvents QT As QueryTable Private Sub qt_BeforeRefresh(Cancel As Boolean) QT.Connection = "ODBC;DSN=Excel Files;DriverId=1046;DBQ=" & ThisWorkbook.FullName End Sub
[/vba]в ЭтаКнига[vba]
Код
Private Sub Workbook_Open() Set Лист1.QT = ThisWorkbook.Connections("запрос").Ranges(1).ListObject.QueryTable End Sub
select f1 as ID, max(iif(f2=2,f3,null)) as Имя, max(iif(f2=5,f3,null)) as Телефон, max(iif(f2=6,f3,null)) as Skype FROM `Лист1$` where f1 is not null group by f1
[/vba] плюс макрос для обновления строки подключения в модуле Лист1[vba]
Код
Public WithEvents QT As QueryTable Private Sub qt_BeforeRefresh(Cancel As Boolean) QT.Connection = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended " & _ "Properties=""excel 12.0 macro;HDR=no"";Data Source=" & ThisWorkbook.FullName End Sub
[/vba]в ЭтаКнига[vba]
Код
Private Sub Workbook_Open() Set Лист1.QT = ThisWorkbook.Connections("запрос").Ranges(1).ListObject.QueryTable End Sub
[/vba]
Вариант с OLEDB подключением текст запроса [vba]
Код
select f1 as ID, max(iif(f2=2,f3,null)) as Имя, max(iif(f2=5,f3,null)) as Телефон, max(iif(f2=6,f3,null)) as Skype FROM `Лист1$` where f1 is not null group by f1
[/vba] плюс макрос для обновления строки подключения в модуле Лист1[vba]
Код
Public WithEvents QT As QueryTable Private Sub qt_BeforeRefresh(Cancel As Boolean) QT.Connection = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended " & _ "Properties=""excel 12.0 macro;HDR=no"";Data Source=" & ThisWorkbook.FullName End Sub
[/vba]в ЭтаКнига[vba]
Код
Private Sub Workbook_Open() Set Лист1.QT = ThisWorkbook.Connections("запрос").Ranges(1).ListObject.QueryTable End Sub
идем по ссылке Tampermonkey for Firefox, жмем [Добавить в Firefox], потом [Установить] после установки дополнения идем по ссылке , жмем [Установить] Готово
идем по ссылке Tampermonkey for Firefox, жмем [Добавить в Firefox], потом [Установить] после установки дополнения идем по ссылке , жмем [Установить] Готово
Sub ShapeUp() Dim i#, j#: j = 1 With ActiveSheet.Shapes(1) .LockAspectRatio = 1 For i = 1 To 2 Step 1 / 400 .ScaleHeight i / j, 0, 0 j = i: DoEvents Next End With End Sub Sub ShapeDown() Dim i#, j#: j = 1 With ActiveSheet.Shapes(1) .LockAspectRatio = 1 For i = 1 To 2 Step 1 / 400 .ScaleHeight j / i, 0, 0 j = i: DoEvents Next End With End Sub
[/vba]
Здравствуйте. Как-то так можно [vba]
Код
Sub ShapeUp() Dim i#, j#: j = 1 With ActiveSheet.Shapes(1) .LockAspectRatio = 1 For i = 1 To 2 Step 1 / 400 .ScaleHeight i / j, 0, 0 j = i: DoEvents Next End With End Sub Sub ShapeDown() Dim i#, j#: j = 1 With ActiveSheet.Shapes(1) .LockAspectRatio = 1 For i = 1 To 2 Step 1 / 400 .ScaleHeight j / i, 0, 0 j = i: DoEvents Next End With End Sub
С наступающим 8 марта милые дамы! От чистого сердца желаю вам счастья, любви, благополучия. Пусть пополнится ваш дом очередным букетом цветов. Пусть не хватает полочек для подарков
С наступающим 8 марта милые дамы! От чистого сердца желаю вам счастья, любви, благополучия. Пусть пополнится ваш дом очередным букетом цветов. Пусть не хватает полочек для подарков krosav4ig
Sub d() Dim sh As Worksheet, rng As Range ActiveSheet.Copy With ActiveWorkbook Set sh = .Sheets(1) On Error Resume Next Do Until Err Set rng = sh.[b2].Resize(sh.Rows.Count - 1).ColumnDifferences(sh.[b2]) If Err = 0 Then Sheets.Add , sh sh.[1:1].Copy sh.Next.[1:1]: rng.EntireRow.Cut sh.Next.[A2] sh.[1:1].Copy: sh.Next.[1:1].PasteSpecial (xlPasteColumnWidths) sh.SaveAs "D:\папка\" & sh.[b2] & ".xlsx": Set sh = sh.Next Loop .Close False End With End Sub
[/vba]
еще вариант [vba]
Код
Sub d() Dim sh As Worksheet, rng As Range ActiveSheet.Copy With ActiveWorkbook Set sh = .Sheets(1) On Error Resume Next Do Until Err Set rng = sh.[b2].Resize(sh.Rows.Count - 1).ColumnDifferences(sh.[b2]) If Err = 0 Then Sheets.Add , sh sh.[1:1].Copy sh.Next.[1:1]: rng.EntireRow.Cut sh.Next.[A2] sh.[1:1].Copy: sh.Next.[1:1].PasteSpecial (xlPasteColumnWidths) sh.SaveAs "D:\папка\" & sh.[b2] & ".xlsx": Set sh = sh.Next Loop .Close False End With End Sub
там еще у вас неразрывный пробел, его туже нужно заменить очистить поля Найти и Заменить на, в поле Найти нажать Alt+255, Заменить все или макрос [vba]
Код
Sub dd() For Each v In Array("-", chr(160)," ", "м."): Selection.Replace v, "", 2: Next End Sub
[/vba]
там еще у вас неразрывный пробел, его туже нужно заменить очистить поля Найти и Заменить на, в поле Найти нажать Alt+255, Заменить все или макрос [vba]
Код
Sub dd() For Each v In Array("-", chr(160)," ", "м."): Selection.Replace v, "", 2: Next End Sub