@Евгений Смирнов, С прошедшими. Спасибо за отзывчивость После консультации с колегами вот к чему пришел
Порядка, ради. Пример в приложении
Код
Sub CreateCSV()
Const sDEL As String = "~"
Dim rngData As Range, vData As Variant
Dim strMyFile As String
Dim i As Long, j As Long
Dim lRows As Long, lCols As Long
Set rngData = ActiveSheet.Range("A1").CurrentRegion
vData = rngData.Value
lRows = UBound(vData, 1)
lCols = UBound(vData, 2)
strMyFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ActiveSheet.Name & ".csv"
Open strMyFile For Output As #1
For i = 1 To lRows
For j = 1 To lCols
vData(i, 1) = vData(i, 1) & sDEL & vData(i, j)
Next j
Print #1, vData(i, 1)
Next i
Close #1
End Sub
Доброго дня, @Евгений Смирнов Спасибо что отозвались. Често говоря пробовал по всякому + трyдность возникает в строках такого вида Например:Paterna Ferrón, Roberto после сохрания макросом Paterna Ferron, Roberto нужно что бы оставалось Paterna Ferrón, Roberto Для порядка прикрепил macro
Sub CreateCSV() 'Save data as CSV with "~" delimiter
Dim Rng As Range, DF1 As Byte, File$, Tp1, Rz$, Ki&, Kj%, i&, j%
Set Rng = ActiveSheet.Cells(1).CurrentRegion
File = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Rng.Parent.Name & ".csv"
Tp1 = Rng.Value: Rz = "~": Ki = Rng.Rows.Count: Kj = Rng.Columns.Count
DF1 = FreeFile: Open File For Output As #DF1
For i = 1 To Ki
For j = 2 To Kj
Tp1(i, 1) = ChangeTextCharset(Tp1(i, 1), "utf-8","Windows-1251") & Rz & Tp1(i, j)
Next j
If i = Ki Then Print #DF1, ChangeTextCharset(Tp1(i, 1), "utf-8","Windows-1251"); Else Print #DF1, ChangeTextCharset(Tp1(i, 1), "utf-8","Windows-1251")
Next i: Close
End Sub
'-----------------------------------------
Function ChangeTextCharset(ByVal txt$, ByVal DestCharset$, Optional ByVal SourceCharset$) As String If Trim(txt$) = "" Then
ChangeTextCharset = ""
Else
On Error Resume Next: Err.Clear
'SourceCharset$ = "Windows-1251"
'DestCharset$ = "utf-8"
With CreateObject("ADODB.Stream")
.Type = 2
.Mode = 3
If Len(SourceCharset$) Then .Charset = SourceCharset$ 'Ischodnaja kodirovka
.Open
.WriteText txt$
.Position = 0
.Charset = DestCharset$ 'Naznachenie novoji kodirovki
ChangeTextCharset = .ReadText
.Close
End With
End If
End Function
Здравствуйте. Протестировал - все работает. Как вы правильно заметили возникла путаница с кодировками. Нужно в UTF-8. На всем известных формах отыскал вот такую функцию. Нахватает понимания как ее внедрить в Ваше решение. Подскажите пожалуйста?
Код
Function ChangeTextCharset(ByVal txt$, ByVal DestCharset$, Optional ByVal SourceCharset$) As String
If Trim(txt$) = "" Then
ChangeTextCharset = ""
Else
On Error Resume Next: Err.Clear
'SourceCharset$ = "Windows-1251"
'DestCharset$ = "utf-8"
With CreateObject("ADODB.Stream")
.Type = 2
.Mode = 3
If Len(SourceCharset$) Then .Charset = SourceCharset$ 'Ischodnaja kodirovka
.Open
.WriteText txt$
.Position = 0
.Charset = DestCharset$ 'Naznachenie novoji kodirovki
ChangeTextCharset = .ReadText
.Close
End With
End If
End Function
Доброго времени суток форум, Есть ощущение что тема совсем не новая... тем не менее. Задача написать процедуру, которая из xlsm файла необходимы лист сохранит как CSV фиал на рабочем столе с разделитель как "~" Спасибо всем кто отзовется.
Код
Sub SaveSheetToCSV()
ActiveWorkbook.SaveAs Filename:="C:\Users\xyz\Desktop\combine.csv", FileFormat:=xlCSVUTF8, Local:=True, CreateBackup:=False
ActiveWorkbook.Close SaveChanges:=False
End Sub
Доброго всем дня, Задача транформировать таблицу как указано в примере. Перенести значения из столбца в трочку. Всех с наступающими праздниками! Спасибо за поддержку!
Здравствуйте. @surkenny Спасибо за два супер хороших примера! Все работает. Нкмного неудобно было работать с "листом" но это уже специфика репорта. Однозначно в копилку знаний. @PooHkrd. Ваша процедура, больше подошла. Она же и была внедрена. Спасибо всем большое!
Привет дорогой форум, Помогите пожалуйста написать процедуру на сравнение строчек в том-же поле/столбце. Прикрепил файл с приблизительным примером. Оригинал выложить не могу (confidential). Спасибо всем кот откликнется.
Доброго времени форум! Помогите пожалуйста неписать короткую процедуру которая покажет поочередно все значения Table1 в ячейке D2 Спасибо всем кто отзовется!
Доброго всем дня, Задача. Есть фиал CD_DB.xlsm. Сразу после открытия WorkBook должен создать своего клона и сохранить на OneDrive далее работа должна быть продолжена в initial файле (который только что был скоприрован). Пример кода ниже. Данный метод .SaveAsCopy работает если фаил находтся локально на машине. При попытке сохранить в облако выдает ошибку Run-Time error 1004. Application defined or object defined error. Спасибо всем кто откликнется на помощь.
Код
'CodeLocation >> ThisWorkbook
Private Sub Workbook_Save()
Dim ThisBook As Workbook
Dim ws As Worksheet
Dim copyName As String
Set ThisBook = ThisWorkbook
Set ws = ThisBook.Worksheets("cover")
'file path connected to named range.
'filepath5 = "https://xxx.sharepoint.com/personal/user_xxx/Documents/CA%20CZ%20Handover/Macro%20preparation/CA%20Tool/Archiving/CA_DB%20Backup%20210521133611.xlsm"
copyName = ws.Range("filepath5")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
If ThisBook.Name <> "CA_DB.xlsm" Then
Exit Sub
Else
ThisWorkbook.SaveCopyAs copyName
ActiveWorkbook.Save
End If
.DisplayAlerts = True
.ScreenUpdating = True
End With
MsgBox "Backup for [CA_DB yyyy-mm-dd hhmmss.xlsm] has been created."
End Sub
Доброго времени суток. Подскажите пожалуйста как скопировать только "синие" листы в только что созднною книгу. Ниже модуль который я подсмотрел и попытался докрутить... прошу о помощи. Фаил прикреплен для наглядности. Спасибо большое!
Доброго дня форум Имеется вот такой код. Подскажите пожалуйста как бы его оптимзировать. Я понимаю что он выглядит громоство и неуклюжо. Особенно когда надо добовлять листы или убирать, такая же история и с даипозонами. Спасибо всем кто отзовется.
Код
Sub recap_data1()
Dim wbk As Workbook
Dim wsh As Worksheet
Dim trgtrng As Range
Dim ConsolidateRangeArray As Variant
Set wbk = Workbooks(Range("BookName").Value)
Set wsh = wbk.Worksheets("Recap")
Set trgtrng = wsh.Range("D12")
ConsolidateRangeArray = Array("5220!R12C4:R14C8", "400E!R12C4:R14C8", _
"4124!R12C4:R14C8", "552E!R12C4:R14C8", _
"5304!R12C4:R14C8", "539D!R12C4:R14C8", _
"5706!R12C4:R14C8", "5356!R12C4:R14C8", _
"4349!R12C4:R14C8", "546E!R12C4:R14C8", _
"4187!R12C4:R14C8", "5255!R12C4:R14C8", _
"5286!R12C4:R14C8", "5244!R12C4:R14C8", _
"5975!R12C4:R14C8", "546P!R12C4:R14C8", _
"443x!R12C4:R14C8", "4104!R12C4:R14C8", _
"5300!R12C4:R14C8", "527P!R12C4:R14C8", _
"504N!R12C4:R14C8", "503N!R12C4:R14C8", _
"502B!R12C4:R14C8", "5985!R12C4:R14C8", _
"5355!R12C4:R14C8", "442N!R12C4:R14C8", _
"4721!R12C4:R14C8")
trgtrng.Consolidate Sources:=ConsolidateRangeArray, Function:=xlSum
End Sub
Столкнулся с другой проблемой. Все то-же в рамках этого PQ. Модераторы, если надо, создам новую тему. Логически видится, продолжение должно быть тут. Вопрос. А что если данные отсутвуют или просто нет файла в file_path и если это так... нужно вывести таблицу (альтернативную) без дынных. Выглядит это как Error Handler.
Что то по типу этого. Но вот не знаю как тут все "закрутить" что бы работало.
Всем спасибо еще раз. Пример ниже.
Код
let
Source_1 = group_1,
Filtered_Rows = Table.SelectRows(
Source_1, each ([Index] = 1)),
Filtered_Rows1 = Table.SelectRows(
Filtered_Rows, each not Text.Contains([Value], "Date")),
Source_2 = Filtered_Rows1,
logic_test = Table.IsEmpty(Source_2), // logic fx, If True then -> Alternative tbl if False then -> Columns
Grouped = Table.Group(
Source_2,
{"Value"},
{{"columns", each List.Skip([Value]), type table}},
0,
(a,b)=>Number.From( Text.Range(b[Value], 3, 1) <> "." ) ),
Сolumns = Table.FromColumns( Grouped[columns], Grouped[Value] ),
alternative_tbl = Excel.CurrentWorkbook(){[Name="tbl_if_nodata"]}[Content],
result = try сolumns otherwise alternative_tbl
in
result
Подскажите пожалуйста, как можно реализовать разбивку таблицы по условию. Пример в приложении. Прошу не судить строго за название темы. Спасибо всем кто отзовется.
Спасибо большое, что отозвались. Как Вы думаете, такое возможно?
Update 08-04-20 так работает. Не совсем по теме, но решает задачу в случает если нет файла или путь к файлу не верный т.е возникает ошибка и как альтернатива выгружется другая (пустая таблица). Строго не судите.
Код
let
FilePath = Excel.CurrentWorkbook(){[Name="Path_CPD2"]}[Content]{0}[Column1],
fileContentsOrError = Excel.Workbook(File.Contents(FilePath), null, true),
tbl_data = fileContentsOrError{[Item="Sheet1",Kind="Sheet"]}[Data],
alternative_tbl = Excel.CurrentWorkbook(){[Name="tbl_Error_Handler"]}[Content],
result = try tbl_data otherwise alternative_tbl,
#"Promoted Headers" = Table.PromoteHeaders(result, [PromoteAllScalars=true])
in
#"Promoted Headers"
Подскажите пожалуйста. Есть ли возможно остановить Query при условии что data sours (фаил или пусть к файлу) отсутствуют? Идеалным в таком случае было бы выгрузить напимер пустую строку и продолжить со следующим Query.
Здравствуйте, Подскажите пожалуйста, как можно взять знаячения из нужного столбца? Формула INDEX MATCH возвращяет значение только из указанного столбца сейчас. Фаил прикреплен. Спасибо.
Оставлю тут. Может пригодится комуто. Мне помогли.
Код
Sub automatic_data_population()
Dim i As Integer
Dim lastrow As Integer
With Sheets("sheet1")
'fetch the row no of lastrow based on the data in column D(4)
lastrow = .Cells(Rows.Count, 4).End(xlUp).Row
'add row ="S", even row = "H"
For i = 11 To lastrow
If i Mod 2 Then
.Cells(i, 3) = "S"
Else
.Cells(i, 3) = "H"
End If
Next
End With
End Sub
Sub copy_filtered_data_1()
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lo As ListObject
Dim iCol_1 As Long
Dim iCol_2 As Long
Dim iCol_3 As Long
Dim wsMapping As Worksheet
Set wsCopy = Worksheets(Range("Sheet_name_support").Value)
Set wsDest = Worksheets("dev_v1")
Set lo = ActiveSheet.ListObjects(1)
Worksheets(Range("Sheet_name_support").Value).Activate
iCol_1 = lo.ListColumns(Range("dev_1_column1").Value).Index
iCol_2 = lo.ListColumns(Range("dev_1_column2").Value).Index
iCol_3 = lo.ListColumns(Range("dev_1_column3").Value).Index
wsCopy.ListObjects(1).ListColumns(iCol_1).DataBodyRange.Copy wsDest.Range("I11")
wsCopy.ListObjects(1).ListColumns(iCol_2).DataBodyRange.Copy wsDest.Range("K11")
wsCopy.ListObjects(1).ListColumns(iCol_3).DataBodyRange.Copy wsDest.Range("D11")
End Sub