Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » cdj100
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1
VBA. Суммирование данных из другой книги по условию., Суммирование по названию месяца.
 
#
28.03.2022 11:15:01
Добрый день, спасибо за формулу! Нужен именно макрос.
 
Перейти    
VBA. Суммирование данных из другой книги по условию., Суммирование по названию месяца.
 
#
25.03.2022 16:34:24
Добрый день, уважаемые форумчане!
Нужна помощь по интегрированию кода в уже существующий, который суммировал бы данные по соответствующему месяцу из двух других книг.
Так, в файле приёмнике QAfinal, напротив каждого месяца из двух книг источников должна возвращаться сумма по соотв. месяцу.
Спасибо!
Код
Sub Get_Value_From_Close_Book33()
    Dim sShName As String, sAddress As String, vData
    Dim objCloseBook As Object
Dim lngI As Long, intI As Integer
Application.ScreenUpdating = False
Range("A1:C15").Select
Selection.ClearContents

lngI = 1
For intI = 1 To 1
Set objCloseBook = GetObject("C:\Users\pavlpid6\Desktop\Ideas\QA matrix new\QA1.xlsx")
sAddress = "(D12:D17)"
vData = objCloseBook.Sheets("Sheet1").Range(sAddress).Value
If IsArray(vData) Then
Range("A" & lngI).Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
Else
Range("A" & lngI) = vData
End If
objCloseBook.Close False
Application.ScreenUpdating = True
lngI = Cells(Rows.Count, 1).End(xlUp).Row + 2

Set objCloseBook = GetObject("C:\Users\pavlpid6\Desktop\Ideas\QA matrix new\QAline.xlsx")
sAddress = "(D12:D17)"
vData = objCloseBook.Sheets("Sheet1").Range(sAddress).Value
If IsArray(vData) Then
Range("A" & lngI).Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
Else
Range("A" & lngI) = vData
End If
objCloseBook.Close False
Application.ScreenUpdating = True
lngI = Cells(Rows.Count, 1).End(xlUp).Row + 2
Next
End Sub
Изменено: cdj100 - 25.03.2022 16:37:12
 
Перейти    
VBA. Копирование диапазонов, вставка диапазонов с пустой строки., VBA. Копирование диапазона из разных книг и вставка диапазонов с пустой строки.
 
#
24.03.2022 10:06:22
С удовольствием, однако текущие условия требуют оперативного решения.
 
Перейти    
VBA. Копирование диапазонов, вставка диапазонов с пустой строки., VBA. Копирование диапазона из разных книг и вставка диапазонов с пустой строки.
 
#
23.03.2022 20:37:29
, работает, большое спасибо!  :)  Следующим шагом как раз и планировалось организовать сбор данных из разных книг. Получился код ниже.
Параллельно, возникла потребность просуммировать данные по условию, я реализовал это след. образом: но в итоговый файл сумма не отображается. Подскажите, в в чем ошибка? (возможно должна быть создана отдельная тема?)
Код
Sub Get_Value_From_Close_Book33()
    Dim sShName As String, sAddress As String, vData
    Dim objCloseBook As Object
Dim lngI As Long, intI As Integer
Application.ScreenUpdating = False
Range("A1:C15").Select
Selection.ClearContents

lngI = 1
For intI = 1 To 1
Set objCloseBook = GetObject("C:\Users\pavlpid6\Desktop\Ideas\QA matrix new\QA1.xlsx")
sAddress = "Application.SumIf(.[С12:С17], [A12], .[E12:F17])"
vData = objCloseBook.Sheets("Sheet1").Range(sAddress).Value
If IsArray(vData) Then
Range("A" & lngI).Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
Else
Range("A" & lngI) = vData
End If
objCloseBook.Close False
Application.ScreenUpdating = True
lngI = Cells(Rows.Count, 1).End(xlUp).Row + 2

Set objCloseBook = GetObject("C:\Users\pavlpid6\Desktop\Ideas\QA matrix new\QAline.xlsx")
sAddress = "Application.SumIf(.[С12:С17], [A12], .[E12:F17])"
vData = objCloseBook.Sheets("Sheet1").Range(sAddress).Value
If IsArray(vData) Then
Range("A" & lngI).Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
Else
Range("A" & lngI) = vData
End If
objCloseBook.Close False
Application.ScreenUpdating = True
lngI = Cells(Rows.Count, 1).End(xlUp).Row + 2
Next
End Sub

Строка суммирования в итоговый файл (QA final) по условию.
Код
sAddress = "Application.SumIf(.[С12:С17], [A12], .[E12:F17])"
 
Перейти    
VBA. Копирование диапазонов, вставка диапазонов с пустой строки., VBA. Копирование диапазона из разных книг и вставка диапазонов с пустой строки.
 
#
22.03.2022 22:29:28
На этом куске кода, перезаписывается с ячейки А1 (цикл пошел по второму разу), а не с последней пустой в столбце А. Ожидается что со второго файла запись начнется с A6.
Уточните пжлст почему?
Код
lngI = Cells(Rows.Count, 1).End(xlUp).Row + 1
 
Перейти    
VBA. Копирование диапазонов, вставка диапазонов с пустой строки., VBA. Копирование диапазона из разных книг и вставка диапазонов с пустой строки.
 
#
22.03.2022 16:02:50
С пустой строки по-прежнему не вставляет диапазон с другой книги.
Некорректная последовательность в коде? Где именно?
Спасибо

Код
Sub Get_Value_From_Close_Book33()
    Dim sShName As String, sAddress As String, vData
    Dim objCloseBook As Object
Dim lngI As Long, intI As Integer
Application.ScreenUpdating = False
Range("A1:A100").Clear
lngI = 1
For intI = 1 To 2
Set objCloseBook = GetObject("C:\Users\pavlpid6\Desktop\Ideas\QA matrix new\QA1.xlsx")
Set objCloseBook = GetObject("C:\Users\pavlpid6\Desktop\Ideas\QA matrix new\QA2.xlsx")
    sAddress = "D12:D18"
    vData = objCloseBook.Sheets("Sheet1").Range(sAddress).Value
        If IsArray(vData) Then
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
      [A1] = vData
    End If
objCloseBook.Close False
Application.ScreenUpdating = True
Range("A" & lngI).PasteSpecial xlPasteValue
lngI = Cells(Rows.Count, 1).End(xlUp).Row + 1
Next intI
End Sub
 
Перейти    
VBA. Копирование диапазонов, вставка диапазонов с пустой строки., VBA. Копирование диапазона из разных книг и вставка диапазонов с пустой строки.
 
#
22.03.2022 13:09:01
Спасибо, вставляет с пустой строки, но не диапазон из второй книги.
Где мне необходимо прописать адрес и диапазон второй книги? На всякий случай высылаю файлы исходники.


Код
Sub name()
Dim lngI As Long, intI As Integer
Dim sShName As String, sAddress As String, vData
'"до цикла чистим заполненный с прошлого раза диапазон, определяем номер строки с которой вставляем"
Range("A1:A100").Clear
lngI = 1
'"Пушшаем цикл по открытию, копированию-вставке и т.д."
'"например, нам надо открыть 2 файла, скопировать, вставить и прочее"
For intI = 1 To 2
    Dim objCloseBook As Object
    '"Отключаем обновление экрана"
    Application.ScreenUpdating = False
    Set objCloseBook = GetObject("C:\Users\pavlpid6\Desktop\Ideas\QA matrix new\QA1.xlsx")
    sAddress = "D12:D16" '"или одна ячейка - "A1""
    '"получаем значениe"
    vData = objCloseBook.Sheets("Sheet1").Range(sAddress).Value
    '"Записываем данные на активный лист книги"
    '"с которой запустили макрос"
    If IsArray(vData) Then
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
      [A1] = vData
    End If
    objCloseBook.Close False
    '"Включаем обновление экрана"
    Application.ScreenUpdating = True
Range("A" & lngI).PasteSpecial xlPasteValue
lngI = Cells(Rows.Count, 1).End(xlUp).Row + 1 '"определяем номер пустой строки после вставки по столбцу А"
'"и не забыть закрыть файл, откуда копировали."
    
    '"Отключаем обновление экрана"
    Application.ScreenUpdating = False
    Set objCloseBook = GetObject("C:\Users\pavlpid6\Desktop\Ideas\QA matrix new\QA2.xlsx")
    sAddress = "D12:D16" '"или одна ячейка - "A1""
    '"получаем значениe"
    vData = objCloseBook.Sheets("Sheet1").Range(sAddress).Value
    '"Записываем данные на активный лист книги"
    '"с которой запустили макрос"
    If IsArray(vData) Then
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
      [A1] = vData
    End If
    objCloseBook.Close False
Next intI

End Sub
 
Перейти    
VBA. Копирование диапазонов, вставка диапазонов с пустой строки., VBA. Копирование диапазона из разных книг и вставка диапазонов с пустой строки.
 
#
22.03.2022 11:52:34
Согласен с Вашим подходом.
Как будет в этом случае выглядеть цикл и как выглядит код поиска и вставки скопированного диапазона с новой строки? С этим основная сложность.
Буду благодарен, если сможете помочь написать такой код, я с VBA не очень силен.
 
Перейти    
VBA. Копирование диапазонов, вставка диапазонов с пустой строки., VBA. Копирование диапазона из разных книг и вставка диапазонов с пустой строки.
 
#
22.03.2022 10:55:58
Добрый день, форумчане. Подскажите, пжлст, как правильно закончить код копирования диапазона из разных книг и вставки диапазона один за другим, начиная с пустой строки?

Код копирования диапазона из одной книги, выглядит таким образом:
Код
Sub Get_Value_From_Close_Book()
    Dim sShName As String, sAddress As String, vData
    Dim objCloseBook As Object
    '"Отключаем обновление экрана"
    Application.ScreenUpdating = False
    Set objCloseBook = GetObject("C:\Users\pavlpid6\Desktop\Ideas\QA matrix new\QA schedule.xlsx")
    sAddress = "D12:D18" '"или одна ячейка - "A1""
    '"получаем значениe"
    vData = objCloseBook.Sheets("Sheet1").Range(sAddress).Value
    '"Записываем данные на активный лист книги"
    '"с которой запустили макрос"
    Range("A1:A100").Clear '"Очищаем диапазон, от старых данных"
    If IsArray(vData) Then
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
      [A1] = vData
    End If
    '"если надо копировать ячейки с форматами"
    '"то можно использовать стандартные методы копирования вставки"
    '"objCloseBook.Sheets("Лист1").Range(sAddress).Copy"
    '"[A1].PasteSpecial xlPasteValues  'вставляем значения"
    '"[A1].PasteSpecial xlPasteFormats '"вставляем форматы"
    '"закрываем книгу(из которой получали значения) без сохранения"
    objCloseBook.Close False
    '"Включаем обновление экрана"
    Application.ScreenUpdating = True
End Sub
 
Перейти    
Копирование заданных колонок из книги, со всех листов., Доработка макроса.
 
#
17.04.2020 23:23:15
Все работает!!!  =))
Спасибо огромное за помощь!!

@Nordheim отдельное спасибо!!!

Возвращаясь к исходной задаче, копирование с двух разных
листов исходника выполнил через два макроса и CALL.
Изменено: cdj100 - 17.04.2020 23:37:40
 
Перейти    
Копирование заданных колонок из книги, со всех листов., Доработка макроса.
 
#
17.04.2020 16:09:03
Nordheim,

Проверяю по наличию скопированных данных на листе приёмника.
Прикрепил файл.
 
Перейти    
Копирование заданных колонок из книги, со всех листов., Доработка макроса.
 
#
17.04.2020 14:56:13
Попытался таким способом скопировать 7 нужных мне диапазонов.
Но копирует только 3
Код
Sub internalncTEST2()
    Dim vData(), ipath$, sht As Worksheet
    ipath = "Z:\Share\FINISHED GOODS, rev 00 (03.01.2020...).xlsx" '"
    Set sht = ThisWorkbook.ActiveSheet
    With GetObject(ipath).Worksheets("0285")
        vData = .[c20:c25].Value
        sht.[a9].Resize(UBound(vData), 2).Value = vData
        vData = .[h20:h25].Value
        sht.[b9].Resize(UBound(vData), 1).Value = vData
        vData = .[i20:i25].Value
        sht.[c9].Resize(UBound(vData), 1).Value = vData
        vData = .[t20:t25].Value
        sht.[d9].Resize(UBound(vData), 1).Value = vData
        vData = .[u20:u25].Value
        sht.[e9].Resize(UBound(vData), 1).Value = vData
        vData = .[v20:v25].Value
        sht.[f9].Resize(UBound(vData), 1).Value = vData
        .Parent.Close False
    End With
End Sub
Изменено: cdj100 - 18.04.2020 10:37:50
 
Перейти    
Копирование заданных колонок из книги, со всех листов., Доработка макроса.
 
#
16.04.2020 21:41:57
Спасибо!
В предложенном случае не ругается, но возвращает только B18:B25.
 
Перейти    
Копирование заданных колонок из книги, со всех листов., Доработка макроса.
 
#
16.04.2020 20:50:32
Пробую вариант с диапазонмиа sAddress и sAddress1 и все работает норм. Но добавляя sAddress2, ругается в строке
Код
vData = Sheets("0285").Range(sAddress, sAddress1, sAddress2).Value

Такое впечатление, что больше двух переменных не видит.
Подскажите, пжслт, что не так?

Код
Sub internalncTEST()
   Dim sShName As String, sAddress As String, sAddress1 As String, sAddress2 As String, vData

    Application.ScreenUpdating = False
    Workbooks.Open "Z:\Share\FINISHED GOODS, rev 00 (03.01.2020...).xlsx" '"
    sShName = "0285"
    sAddress = ("B18:B25")
    sAddress1 = ("C18:C25")
    sAddress2 = ("F18:F25")

    vData = Sheets("0285").Range(sAddress, sAddress1, sAddress2).Value
    ActiveWorkbook.Close False
    
    If IsArray(vData) Then
        [A9].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [A9] = vData
    End If

    Application.ScreenUpdating = True
End Sub
Изменено: cdj100 - 17.04.2020 15:03:32
 
Перейти    
Копирование заданных колонок из книги, со всех листов., Доработка макроса.
 
#
16.04.2020 09:43:55
Добрый день, форумчане.
Подскажите, пожалуйста, как доработать макрос: открываю закрыту книгу, из каждой имеющейся вкладки закрытого файла мне надо скопировать несколько заданных колонок, н-р. A:A, C:C, W:W.
Код
Sub internalnc()
    Dim sShName As String, sAddress As String, vData
   
    Application.ScreenUpdating = False
    Workbooks.Open "Z:\Share\FINISHED GOODS, rev 00 (03.01.2020...).xlsx" '"
    sShName = "0285"
    sAddress = "A:A" 
   
    vData = Sheets("0285").Range(sAddress).Value
    ActiveWorkbook.Close False

    If IsArray(vData) Then
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [A1] = vData
    End If
 
    Application.ScreenUpdating = True
End Sub
Изменено: cdj100 - 16.04.2020 09:45:00
 
Перейти    
Отбор данных в другую таблицу с учетом формата
 
#
31.03.2020 20:55:55
Доработал копирование в таблицу по формату.

Подскажите, пжлст, как можно скрыть теперь пустые ячейки в итоговой таблице? (не в ручную)
Пробую создать соседнюю таблицу, но по какому принципу упорядочить записи без пустых ячеек не понятно.

Большое спасибо!
 
Перейти    
Отбор данных в другую таблицу с учетом формата
 
#
30.03.2020 20:41:33
Большое спасибо, работает!

А подскажите если список постоянно пополняется, как мне настроить автоматический перенос цвета, партии и номера колонны в соответсвтующую таблицу? (н-р в таблице 500 это столбцы O, P и R)? Есть ли формула/способ, позволяющий не делать это в ручную?
 
Перейти    
Отбор данных в другую таблицу с учетом формата
 
#
27.03.2020 12:05:12
Добрый день, уважаемые форумчане!
Подскажите, пожалуйста, как можно обработать пополняемый список по нескольким условиям?

Имеется пополняемая база данных (список): формат, цвет, партия, кол-во, номер колонны и куда размещается или отгружается товар.
Необходимо
1. Сортируя список по формату (500/750/1000) и перенести в соответствующую таблицу, с указанием цвета, кол-ва и номера колонны.
2. Далее, если в рамаках одного формата, одного цвета есть одинаковые партии, то смотрим сколько добавил и отгрузил.
В итоге, в таблице должен остаться остаток партии.

Например: в списке "500 красный 28420067", в одной и той же колонне добаили 21, а потом отгрузили 15 единиц товара.
На остатках 6 шт.
Аналогично с форматом 1000.

Есть ли возможность написать формулу для такой обработки поступающих данных?
Предполагаю, требуются промежуточные массивы для хранения уникальных партий. Откуда можно копировать в итоговую таблицу.

Большое спасибо!
 
Перейти    
Перенос данных из нескольких книг в одну, c заданной ячейк., Доработка существующего макроса.
 
#
27.12.2019 15:54:14
А хотелось бы таким образом:
Изменено: cdj100 - 27.12.2019 15:54:31
 
Перейти    
Перенос данных из нескольких книг в одну, c заданной ячейк., Доработка существующего макроса.
 
#
27.12.2019 15:53:47
Получается вот такой результат:
Изменено: cdj100 - 27.12.2019 15:57:17
 
Перейти    
Перенос данных из нескольких книг в одну, c заданной ячейк., Доработка существующего макроса.
 
#
27.12.2019 15:22:43
Спасибо огромное, с ячейкой все отлично работает  

Но вот символы по-прежнему не выходят в полном составе. Подскажите, что может быть не так!?
 
Перейти    
Перенос данных из нескольких книг в одну, c заданной ячейк., Доработка существующего макроса.
 
#
27.12.2019 14:43:49
Пожалуйста: текущий файл и две книги .csv

P.S. также обратил внимание, что копирует данные по умолчанию в следующий столбец, а не в выделенную мной ячейку.
Это не совсем удобно, так как иногда необходимо копировать в любую выделенную ячейку.
Можно ли это скорректировать?
 
Перейти    
Перенос данных из нескольких книг в одну, c заданной ячейк., Доработка существующего макроса.
 
#
27.12.2019 13:59:37
Работает  :D !!!  
Но почему-то копирует только первый символ из диапазона А1-А13, тогда как в каждой ячейке их около 50.
Подскажите, что в коде нужно изменить?
 
Перейти    
Перенос данных из нескольких книг в одну, c заданной ячейк., Доработка существующего макроса.
 
#
27.12.2019 13:41:25
Подскажите пжлст как будет выглядеть окончательный код?
Пробую несколько варинатов - иксель виснет. С макросами делаю первые шаги, строго прошу не судить.  
Код
Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
 
    Application.ScreenUpdating = False  '????????? ?????????? ?????? ??? ????????
     
    '???????? ?????? ?????? ?????? ??? ???????
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge")
 
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "?? ??????? ?? ?????? ?????!"
        Exit Sub
    End If
     
    '???????? ?? ???? ????????? ??????
    x = 1
    While x <= UBound(FilesToOpen)
        Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
        'Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
With ThisWorkbook.Sheets(1)
    Set r = .Cells(1, .Columns.Count).End(xlToLeft).Cells(1, 2)
End With
Sheets(1).Range("A1:A13").Copy r
    Wend
 
    Application.ScreenUpdating = True
End Sub
 
Перейти    
Перенос данных из нескольких книг в одну, c заданной ячейк., Доработка существующего макроса.
 
#
27.12.2019 10:24:40
Добрый день, на данном форуме был макрос по копированию листов из выбранных книг в текущую.

Подскажите пожалуйста, как корректно изменить код так, чтобы он копировал указанный диапазон (например, А1:A13) со всех листов1 указанного набора книг в текущую книгу, но делал это в выделенную мной ячейку. Н-р: из первых двух книг данные копируются в столбцы A,B.
А при каждом добавлении новых книг, данные копировались бы, начиная со следующего столбца С,D,E..... И т.д.
Код
Sub CombineWorkbooks()
Dim FilesToOpen
Dim x As Integer

Application.ScreenUpdating = False &#39;отключаем обновление экрана для скорости

&#39;вызываем диалог выбора файлов для импорта
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="All files (*.*), *.*", _
MultiSelect:=True, Title:="Files to Merge")

If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "Не выбрано ни одного файла!"
Exit Sub
End If

&#39;проходим по всем выбранным файлам
x = 1
While x <= UBound(FilesToOpen)
Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
importWB.Close savechanges:=False
x = x + 1
Wend

Application.ScreenUpdating = True
End Sub
 
Перейти    
N-ое вхождение символа в ячейке, Не работает формула.
 
#
13.12.2019 15:41:49
Странно, два раза проверял перед ответом-не работало.
Сечас все ок.

Большое всем спасибо за помощь!
 
Перейти    
N-ое вхождение символа в ячейке, Не работает формула.
 
#
13.12.2019 15:25:31
Цитата
БМВ написал:
но правильнее так=FIND("@";SUBSTITUTE(C4;"т";"@";3))Вместо " можно использовать любой символ, который не встретится в строке.
Второй вариант, как самостоятельная формула, не работает.
Возможно, я что-то упустил или не правильно её применяю.... Подскажите, где ошибка?
 
Перейти    
N-ое вхождение символа в ячейке, Не работает формула.
 
#
13.12.2019 14:14:04
Перезалил файл в xls, та же картина.
3-е вхожденеи не работает.
 
Перейти    
N-ое вхождение символа в ячейке, Не работает формула.
 
#
13.12.2019 13:58:30
Добрый день форумчане!

Подскажите, пожалуйтса, почему не работает формула на определение 3-го положение символа в ячейке.
1-е и 2-е вхождение определяет, а начиная с 3-его нет.
В чем проблема, как исправить?

Большое спасибо!
Изменено: cdj100 - 13.12.2019 14:12:57
 
Перейти    
Страницы: 1
Наверх