Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Проверка столбцов перед копированием и последуещее умножение - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_, DrMini  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Проверка столбцов перед копированием и последуещее умножение (Макросы/Sub)
Проверка столбцов перед копированием и последуещее умножение
cresh12 Дата: Вторник, 22.09.2015, 16:12 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте. Очень нужна Ваша помощь. Пытаюсь сделать так чтобы при копировании данных из исходной книги в новую значения ячеек в двух столбцах были умноженными на 1000. Пробовал различные варианты, но не один не получилось заставить работать. Надеюсь на Вашу помощь. Спасибо. Прикрепляю исходный файл. В коде выделил места какие столбцы необходимо умножить. И еще такой вопрос, мне надо сделать условие для проверки перед копирование информации с одной книги на другую (проверка столбца Z, если не пустая строка в этом столбце, то копировать в новую книгу) Как я понимаю это надо делать через if, или есть еще другие варианты?)
[vba]
Код
     

Private Sub Command1_Click()

         Dim objExcel, objWorkbook
         Set objExcel = CreateObject("EXCEL.APPLICATION")
             objExcel.Visible = False
'Ïóòü ê èñõîäíîìó ôàéëó
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\Varina_LI\Desktop\ïðèìåð\ms21.xlsx")

Dim d As Long
Application.ScreenUpdating = False
        Dim shSrc As Worksheet, shRes As Worksheet
        Dim lrRes As Long
        Dim New_Wb As Workbook
        Dim i As Integer
        Dim x As Integer
        Dim result As Integer
        Application.ScreenUpdating = False
        Set New_Wb = Workbooks.Add
        New_Wb.Activate
        'Ïóòü ãäå ñîçäàåòñÿ íîâûé ôàéë
        New_Wb.SaveAs FileName:="C:\Users\Varina_LI\Desktop\ïðèìåð\maket17_ms21.xlsx"
        New_Wb.Close True
        Set shSrc = ActiveSheet
        'Äîëæíû ñîâïàäàòü
        Set shRes = Workbooks.Open("C:\Users\Varina_LI\Desktop\ïðèìåð\maket17_ms21.xlsx").Worksheets(1)
          
        Range("A1") = "MAK"
        Range("B1") = "PACH"
        Range("C1") = "IZ"
        Range("D1") = "MOD"
        Range("E1") = "NSP"
        Range("F1") = "NDT"
        Range("G1") = "SHPR"
        Range("H1") = "KSB"
        Range("I1") = "KIZ"
        Range("J1") = "WES"
        Range("K1") = "SWW"
        Range("L1") = "SOG"
        Range("M1") = "SHP"
        Range("N1") = "EI"
        Range("O1") = "NNM"
        Range("P1") = "NOR"
        Range("Q1") = "GOP"
        Range("R1") = "ZPD"
        Range("S1") = "Z0"
        Range("T1") = "Z1"
        Range("U1") = "Z2"
        Range("V1") = "Z3"
        Range("W1") = "Z4"
        Range("X1") = "Z5"
        Range("Y1") = "NDOC"
        Range("Z1") = "PROB"
        Range("AA1") = "VER"
          
        Rows("1:1").Select
        With Selection
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlCenter
            .WrapText = True
        End With
          
          
         lrRes = shRes.Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row + 1
                
        shSrc.Activate
        d = shSrc.Cells(Rows.Count, 5).End(xlUp).Row

        shRes.Range("A2 :A" & d & "") = "17"
        shRes.Range("B2 :B" & d & "") = "001"
        shRes.Range("C2 :C" & d & "") = "2"
        shRes.Range("D2 :D" & d & "") = "11"
        shRes.Range("G2 :G" & d & "") = "11"
        shRes.Range("M2 :M" & d & "") = "00"
        shRes.Range("AA2 :AA" & d & "") = "1"
            
        shSrc.Range("B2:B" & d & "").Copy
        shRes.Cells(lrRes, 5).PasteSpecial xlPasteValues
        shSrc.Range("C2:C" & d & "").Copy
        shRes.Cells(lrRes, 6).PasteSpecial xlPasteValues
        shSrc.Range("J2:J" & d & "").Copy
        shRes.Cells(lrRes, 8).PasteSpecial xlPasteValues
        shSrc.Range("K2:K" & d & "").Copy
        shRes.Cells(lrRes, 9).PasteSpecial xlPasteValues

            
        '  \/ здесь надо умножить *1000
       ' Cells(10000, 10000) = "1000"
       Dim c As Range
       shSrc.Range("L2:L" & d & "").Copy
       shRes.Cells(lrRes, 10).PasteSpecial xlPasteValues
           
       ' Set c = Cells.SpecialCells(xlCellTypeBlanks).Cells(1, 1)
'
     '   c = 341
      '  c.Copy
       ' Range("J2:J4").PasteSpecial Operation:=xlMultiply

'    c.Clear
          
          
        'xlPasteValues Operation:=xlMultiply
       ' shSrc.Range ("L2:L" & d & "* 1000")
     'Dim rng As Range
      '  Dim avarItems As Variant
       ' Dim intI As Variant
            
        'Set rng = Range("L2:L" & d & "")
        'avarItems = rng
            
       ' For intI = 1 To UBound(avarItems, 1)
       '     avarItems(intI, 1) = avarItems(intI, 1) * 1000
        'Next intI
                
        'rng = avarItems

        '---------------------------------------

            
        shSrc.Range("N2:N" & d & "").Copy
        shRes.Cells(lrRes, 11).PasteSpecial xlPasteValues
        shSrc.Range("O2:O" & d & "").Copy
        shRes.Cells(lrRes, 12).PasteSpecial xlPasteValues
        shSrc.Range("Y2:Y" & d & "").Copy
        shRes.Cells(lrRes, 14).PasteSpecial xlPasteValues
        shSrc.Range("Z2:Z" & d & "").Copy
        shRes.Cells(lrRes, 15).PasteSpecial xlPasteValues
            
        '  \/ здесь надо умножить *1000
        shSrc.Range("AC2:AC" & d & "").Copy
        shRes.Cells(lrRes, 16).PasteSpecial xlPasteValues
        '---------------------------------------
            
        shSrc.Range("AI2:AI" & d & "").Copy
        shRes.Cells(lrRes, 17).PasteSpecial xlPasteValues
        shSrc.Range("AJ2:AJ" & d & "").Copy
        shRes.Cells(lrRes, 18).PasteSpecial xlPasteValues
        shSrc.Range("AK2:AK" & d & "").Copy
        shRes.Cells(lrRes, 19).PasteSpecial xlPasteValues
        shSrc.Range("AL2:AL" & d & "").Copy
        shRes.Cells(lrRes, 20).PasteSpecial xlPasteValues
        shSrc.Range("AM2:AM" & d & "").Copy
        shRes.Cells(lrRes, 21).PasteSpecial xlPasteValues
        shSrc.Range("AN2:AN" & d & "").Copy
        shRes.Cells(lrRes, 22).PasteSpecial xlPasteValues
        shSrc.Range("AO2:AO" & d & "").Copy
        shRes.Cells(lrRes, 23).PasteSpecial xlPasteValues
        shSrc.Range("AP2:AP" & d & "").Copy
        shRes.Cells(lrRes, 24).PasteSpecial xlPasteValues
         
        Application.CutCopyMode = False
        shRes.Parent.Close 1
        Application.ScreenUpdating = True
        MsgBox "Ìàêåò 17 äëÿ ÌÑ21 óñïåøíî ñôîðìèðîâàí"
        objExcel.ActiveWorkbook.Close savechanges:=False
End Sub
[/vba]
К сообщению приложен файл: 4647170.xlsx (57.5 Kb)


Сообщение отредактировал cresh12 - Среда, 23.09.2015, 08:13
 
Ответить
СообщениеЗдравствуйте. Очень нужна Ваша помощь. Пытаюсь сделать так чтобы при копировании данных из исходной книги в новую значения ячеек в двух столбцах были умноженными на 1000. Пробовал различные варианты, но не один не получилось заставить работать. Надеюсь на Вашу помощь. Спасибо. Прикрепляю исходный файл. В коде выделил места какие столбцы необходимо умножить. И еще такой вопрос, мне надо сделать условие для проверки перед копирование информации с одной книги на другую (проверка столбца Z, если не пустая строка в этом столбце, то копировать в новую книгу) Как я понимаю это надо делать через if, или есть еще другие варианты?)
[vba]
Код
     

Private Sub Command1_Click()

         Dim objExcel, objWorkbook
         Set objExcel = CreateObject("EXCEL.APPLICATION")
             objExcel.Visible = False
'Ïóòü ê èñõîäíîìó ôàéëó
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\Varina_LI\Desktop\ïðèìåð\ms21.xlsx")

Dim d As Long
Application.ScreenUpdating = False
        Dim shSrc As Worksheet, shRes As Worksheet
        Dim lrRes As Long
        Dim New_Wb As Workbook
        Dim i As Integer
        Dim x As Integer
        Dim result As Integer
        Application.ScreenUpdating = False
        Set New_Wb = Workbooks.Add
        New_Wb.Activate
        'Ïóòü ãäå ñîçäàåòñÿ íîâûé ôàéë
        New_Wb.SaveAs FileName:="C:\Users\Varina_LI\Desktop\ïðèìåð\maket17_ms21.xlsx"
        New_Wb.Close True
        Set shSrc = ActiveSheet
        'Äîëæíû ñîâïàäàòü
        Set shRes = Workbooks.Open("C:\Users\Varina_LI\Desktop\ïðèìåð\maket17_ms21.xlsx").Worksheets(1)
          
        Range("A1") = "MAK"
        Range("B1") = "PACH"
        Range("C1") = "IZ"
        Range("D1") = "MOD"
        Range("E1") = "NSP"
        Range("F1") = "NDT"
        Range("G1") = "SHPR"
        Range("H1") = "KSB"
        Range("I1") = "KIZ"
        Range("J1") = "WES"
        Range("K1") = "SWW"
        Range("L1") = "SOG"
        Range("M1") = "SHP"
        Range("N1") = "EI"
        Range("O1") = "NNM"
        Range("P1") = "NOR"
        Range("Q1") = "GOP"
        Range("R1") = "ZPD"
        Range("S1") = "Z0"
        Range("T1") = "Z1"
        Range("U1") = "Z2"
        Range("V1") = "Z3"
        Range("W1") = "Z4"
        Range("X1") = "Z5"
        Range("Y1") = "NDOC"
        Range("Z1") = "PROB"
        Range("AA1") = "VER"
          
        Rows("1:1").Select
        With Selection
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlCenter
            .WrapText = True
        End With
          
          
         lrRes = shRes.Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row + 1
                
        shSrc.Activate
        d = shSrc.Cells(Rows.Count, 5).End(xlUp).Row

        shRes.Range("A2 :A" & d & "") = "17"
        shRes.Range("B2 :B" & d & "") = "001"
        shRes.Range("C2 :C" & d & "") = "2"
        shRes.Range("D2 :D" & d & "") = "11"
        shRes.Range("G2 :G" & d & "") = "11"
        shRes.Range("M2 :M" & d & "") = "00"
        shRes.Range("AA2 :AA" & d & "") = "1"
            
        shSrc.Range("B2:B" & d & "").Copy
        shRes.Cells(lrRes, 5).PasteSpecial xlPasteValues
        shSrc.Range("C2:C" & d & "").Copy
        shRes.Cells(lrRes, 6).PasteSpecial xlPasteValues
        shSrc.Range("J2:J" & d & "").Copy
        shRes.Cells(lrRes, 8).PasteSpecial xlPasteValues
        shSrc.Range("K2:K" & d & "").Copy
        shRes.Cells(lrRes, 9).PasteSpecial xlPasteValues

            
        '  \/ здесь надо умножить *1000
       ' Cells(10000, 10000) = "1000"
       Dim c As Range
       shSrc.Range("L2:L" & d & "").Copy
       shRes.Cells(lrRes, 10).PasteSpecial xlPasteValues
           
       ' Set c = Cells.SpecialCells(xlCellTypeBlanks).Cells(1, 1)
'
     '   c = 341
      '  c.Copy
       ' Range("J2:J4").PasteSpecial Operation:=xlMultiply

'    c.Clear
          
          
        'xlPasteValues Operation:=xlMultiply
       ' shSrc.Range ("L2:L" & d & "* 1000")
     'Dim rng As Range
      '  Dim avarItems As Variant
       ' Dim intI As Variant
            
        'Set rng = Range("L2:L" & d & "")
        'avarItems = rng
            
       ' For intI = 1 To UBound(avarItems, 1)
       '     avarItems(intI, 1) = avarItems(intI, 1) * 1000
        'Next intI
                
        'rng = avarItems

        '---------------------------------------

            
        shSrc.Range("N2:N" & d & "").Copy
        shRes.Cells(lrRes, 11).PasteSpecial xlPasteValues
        shSrc.Range("O2:O" & d & "").Copy
        shRes.Cells(lrRes, 12).PasteSpecial xlPasteValues
        shSrc.Range("Y2:Y" & d & "").Copy
        shRes.Cells(lrRes, 14).PasteSpecial xlPasteValues
        shSrc.Range("Z2:Z" & d & "").Copy
        shRes.Cells(lrRes, 15).PasteSpecial xlPasteValues
            
        '  \/ здесь надо умножить *1000
        shSrc.Range("AC2:AC" & d & "").Copy
        shRes.Cells(lrRes, 16).PasteSpecial xlPasteValues
        '---------------------------------------
            
        shSrc.Range("AI2:AI" & d & "").Copy
        shRes.Cells(lrRes, 17).PasteSpecial xlPasteValues
        shSrc.Range("AJ2:AJ" & d & "").Copy
        shRes.Cells(lrRes, 18).PasteSpecial xlPasteValues
        shSrc.Range("AK2:AK" & d & "").Copy
        shRes.Cells(lrRes, 19).PasteSpecial xlPasteValues
        shSrc.Range("AL2:AL" & d & "").Copy
        shRes.Cells(lrRes, 20).PasteSpecial xlPasteValues
        shSrc.Range("AM2:AM" & d & "").Copy
        shRes.Cells(lrRes, 21).PasteSpecial xlPasteValues
        shSrc.Range("AN2:AN" & d & "").Copy
        shRes.Cells(lrRes, 22).PasteSpecial xlPasteValues
        shSrc.Range("AO2:AO" & d & "").Copy
        shRes.Cells(lrRes, 23).PasteSpecial xlPasteValues
        shSrc.Range("AP2:AP" & d & "").Copy
        shRes.Cells(lrRes, 24).PasteSpecial xlPasteValues
         
        Application.CutCopyMode = False
        shRes.Parent.Close 1
        Application.ScreenUpdating = True
        MsgBox "Ìàêåò 17 äëÿ ÌÑ21 óñïåøíî ñôîðìèðîâàí"
        objExcel.ActiveWorkbook.Close savechanges:=False
End Sub
[/vba]
Автор - cresh12
Дата добавления - 22.09.2015 в 16:12
cresh12 Дата: Среда, 23.09.2015, 09:48 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Умножение сделал, помогите пожалуйста разобраться с проверкой перед копированием)
 
Ответить
СообщениеУмножение сделал, помогите пожалуйста разобраться с проверкой перед копированием)
Автор - cresh12
Дата добавления - 23.09.2015 в 09:48
Roman777 Дата: Среда, 23.09.2015, 10:26 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
Таким способом, как вы пытаетесь, у Вас не получится скопированные значения и сразу же с ними провести какую-либо операцию (умножение, например, на 1000).
[vba]
Код
        shSrc.Range("AI2:AI" & d & "").Copy
         shRes.Cells(lrRes, 17).PasteSpecial xlPasteValues
[/vba]
данное выражение, по сути, это копирование массива (области) ячеек именно, а не значений.
Чтобы вы могли скопировать и на что-то умножить, удобнее пользоваться массивами:
[vba]
Код
Dim
scSrcArr()   ' Объявление массива
....

Redim scSrcArr(d, 4) ' Задаём размерность и определяем 2-мерный массив, в котором размерность d - я принял за d ячеек, которые вы планируете записать, а размерность 4 - количество столбцов из которых вы планируете записать данные. Причём сразу оговорюсь, на самом деле у массива размерность будет выше чем требуется (поскольку Вы записываете данные не с первой строки, ну и помимо всего у массивов в данном случае есть и нулевая размерность. Но для данной задачи, думаю, это не принципиально.
For i = 2 to d
scSrcArr(i, 1) = shSrc.Range("N" & d )*1000 ' можно записывая данные в массив сразу умножать или...
scSrcArr(i, 2) = shSrc.Range("O" & d )*1000
scSrcArr(i, 3) = shSrc.Range("Y" & d )*1000
scSrcArr(i, 4) = shSrc.Range("Z" & d )*1000
next i
For i = 2 to d
shRes.Cells(lrRes, 11)=scSrcArr(i, 1)  ' или можно умножать тут, записывая данные из массива.
shRes.Cells(lrRes, 12)=scSrcArr(i, 2)
shRes.Cells(lrRes, 14)=scSrcArr(i, 3)
shRes.Cells(lrRes, 15)=scSrcArr(i, 4)
next i
[/vba]
Только сейчас заметил, что не для тех ячеек привёл пример, но там всё по аналогии...)

Много чего не знаю!!!!
 
Ответить
СообщениеТаким способом, как вы пытаетесь, у Вас не получится скопированные значения и сразу же с ними провести какую-либо операцию (умножение, например, на 1000).
[vba]
Код
        shSrc.Range("AI2:AI" & d & "").Copy
         shRes.Cells(lrRes, 17).PasteSpecial xlPasteValues
[/vba]
данное выражение, по сути, это копирование массива (области) ячеек именно, а не значений.
Чтобы вы могли скопировать и на что-то умножить, удобнее пользоваться массивами:
[vba]
Код
Dim
scSrcArr()   ' Объявление массива
....

Redim scSrcArr(d, 4) ' Задаём размерность и определяем 2-мерный массив, в котором размерность d - я принял за d ячеек, которые вы планируете записать, а размерность 4 - количество столбцов из которых вы планируете записать данные. Причём сразу оговорюсь, на самом деле у массива размерность будет выше чем требуется (поскольку Вы записываете данные не с первой строки, ну и помимо всего у массивов в данном случае есть и нулевая размерность. Но для данной задачи, думаю, это не принципиально.
For i = 2 to d
scSrcArr(i, 1) = shSrc.Range("N" & d )*1000 ' можно записывая данные в массив сразу умножать или...
scSrcArr(i, 2) = shSrc.Range("O" & d )*1000
scSrcArr(i, 3) = shSrc.Range("Y" & d )*1000
scSrcArr(i, 4) = shSrc.Range("Z" & d )*1000
next i
For i = 2 to d
shRes.Cells(lrRes, 11)=scSrcArr(i, 1)  ' или можно умножать тут, записывая данные из массива.
shRes.Cells(lrRes, 12)=scSrcArr(i, 2)
shRes.Cells(lrRes, 14)=scSrcArr(i, 3)
shRes.Cells(lrRes, 15)=scSrcArr(i, 4)
next i
[/vba]
Только сейчас заметил, что не для тех ячеек привёл пример, но там всё по аналогии...)
Автор - Roman777
Дата добавления - 23.09.2015 в 10:26
Roman777 Дата: Среда, 23.09.2015, 10:31 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
cresh12,
Цитата cresh12, 22.09.2015 в 16:12, в сообщении № 1
(проверка столбца Z, если не пустая строка в этом столбце, то копировать в новую книгу) Как я понимаю это надо делать через if, или есть еще другие варианты?)
тут просто не очень понятно. Вы хотите проверять каждую Zi -ю ячейку и если она не пустая, записывать её в Zi-ю ячейку другой книги? Почему не хотите копировать все и пустые и непустые?

Много чего не знаю!!!!
 
Ответить
Сообщениеcresh12,
Цитата cresh12, 22.09.2015 в 16:12, в сообщении № 1
(проверка столбца Z, если не пустая строка в этом столбце, то копировать в новую книгу) Как я понимаю это надо делать через if, или есть еще другие варианты?)
тут просто не очень понятно. Вы хотите проверять каждую Zi -ю ячейку и если она не пустая, записывать её в Zi-ю ячейку другой книги? Почему не хотите копировать все и пустые и непустые?
Автор - Roman777
Дата добавления - 23.09.2015 в 10:31
cresh12 Дата: Среда, 23.09.2015, 10:39 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Roman777, Нужно проверять все строки по Zi ячейке и если она не пустая то копировать столбцы. А если пустая то такие строки не копировать. Не получается ясней сформулировать). Проще говоря, надо копировать строки из столбцов только тогда когда столбец Z не пустой)


Сообщение отредактировал cresh12 - Среда, 23.09.2015, 10:41
 
Ответить
СообщениеRoman777, Нужно проверять все строки по Zi ячейке и если она не пустая то копировать столбцы. А если пустая то такие строки не копировать. Не получается ясней сформулировать). Проще говоря, надо копировать строки из столбцов только тогда когда столбец Z не пустой)
Автор - cresh12
Дата добавления - 23.09.2015 в 10:39
cresh12 Дата: Среда, 23.09.2015, 11:10 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Roman777, а еще можно уточнить, вот пытаюсь переделать программу в тот вариант который Вы предложили. [vba]
Код
Dim scSrcArr()
     ReDim scSrcArr(d, 10)
     For i = 2 To d
     scSrcArr(i, 1) = shSrc.Range("B2 :B" & d & "")
     scSrcArr(i, 2) = shSrc.Range("C2 :C" & d & "")
     Next i
     For i = 2 To d
     shRes.Cells(lrRes, 5) = scSrcArr(i, 1)
     shRes.Cells(lrRes, 6) = scSrcArr(i, 2)
     Next i
[/vba]
Пока только 2 столбца для примера пробую. Так вот подскажите пожалуйста почему переносится только одна ячейка из каждого столбца?) и можно ли сделать с помощью массива чтобы переносился весь столбец?)
 
Ответить
СообщениеRoman777, а еще можно уточнить, вот пытаюсь переделать программу в тот вариант который Вы предложили. [vba]
Код
Dim scSrcArr()
     ReDim scSrcArr(d, 10)
     For i = 2 To d
     scSrcArr(i, 1) = shSrc.Range("B2 :B" & d & "")
     scSrcArr(i, 2) = shSrc.Range("C2 :C" & d & "")
     Next i
     For i = 2 To d
     shRes.Cells(lrRes, 5) = scSrcArr(i, 1)
     shRes.Cells(lrRes, 6) = scSrcArr(i, 2)
     Next i
[/vba]
Пока только 2 столбца для примера пробую. Так вот подскажите пожалуйста почему переносится только одна ячейка из каждого столбца?) и можно ли сделать с помощью массива чтобы переносился весь столбец?)
Автор - cresh12
Дата добавления - 23.09.2015 в 11:10
miver Дата: Среда, 23.09.2015, 11:20 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 190
Репутация: 37 ±
Замечаний: 0% ±

Excel 2010
cresh12, Вот переделал Ваш код, на сколько понял
[vba]
Код

Sub Click()
     Dim objExcel, objWorkbook As Workbook
     Set objExcel = CreateObject("EXCEL.APPLICATION")
     objExcel.Visible = False
     Set objWorkbook = objExcel.Workbooks.Open(ThisWorkbook.Path & "\ms21.xlsx")
      
     With objWorkbook.ActiveSheet
         d = .Cells(.Rows.Count, 5).End(xlUp).Row
         arrSrc = .Range("A1 :AP" & d).Value
     End With
      
     objWorkbook.Close savechanges:=False
      
     ColNames = [{"MAK","PACH","IZ","MOD","NSP","NDT","SHPR","KSB","KIZ","WES","SWW","SOG","SHP","EI","NNM","NOR","GOP","ZPD","Z0","Z1","Z2","Z3","Z4","Z5"," NDOC","PROB","VER"}]
      
     Dim arrRes()
     ReDim arrRes(1 To UBound(arrSrc), 1 To UBound(arrSrc, 2))
     r = 1
     For i = 1 To UBound(arrSrc)
         If i = 1 Then
             For j = 1 To UBound(ColNames)
                 arrRes(r, j) = ColNames(j)
             Next j
             r = r + 1
         ElseIf Not arrSrc(i, 6) = "" Then
             For j = 1 To UBound(arrSrc, 2)
                 Data = ""
                 Select Case j
                     Case 1
                         Data = "17"
                     Case 4
                         Data = "11"
                     Case 7
                         Data = "11"
                     Case 13
                         Data = "00"
                     Case 27
                         Data = "1"
                     Case 12
                         ' умножение на 1000
                         Data = Val(arrSrc(i, j)) * 1000
                     Case Else
                         Data = arrSrc(i, j)
                 End Select
                  
                 arrRes(r, j) = Data
             Next j
             r = r + 1
         End If
     Next i
      
     Dim New_Wb As Workbook
     Set New_Wb = Workbooks.Add
     New_Wb.ActiveSheet.Range("A1").Resize(UBound(arrRes), UBound(arrRes, 2)).Value = arrRes
     New_Wb.SaveAs Filename:=ThisWorkbook.Path & "\maket17_ms21.xlsx"
     MsgBox "Макет 17 для МС21 успешно сформирован"
End Sub
[/vba]
Файл поместите в одну папку с "ms21.xlsx" и нажмите кнопку
К сообщению приложен файл: 8250477.xlsb (14.3 Kb)
 
Ответить
Сообщениеcresh12, Вот переделал Ваш код, на сколько понял
[vba]
Код

Sub Click()
     Dim objExcel, objWorkbook As Workbook
     Set objExcel = CreateObject("EXCEL.APPLICATION")
     objExcel.Visible = False
     Set objWorkbook = objExcel.Workbooks.Open(ThisWorkbook.Path & "\ms21.xlsx")
      
     With objWorkbook.ActiveSheet
         d = .Cells(.Rows.Count, 5).End(xlUp).Row
         arrSrc = .Range("A1 :AP" & d).Value
     End With
      
     objWorkbook.Close savechanges:=False
      
     ColNames = [{"MAK","PACH","IZ","MOD","NSP","NDT","SHPR","KSB","KIZ","WES","SWW","SOG","SHP","EI","NNM","NOR","GOP","ZPD","Z0","Z1","Z2","Z3","Z4","Z5"," NDOC","PROB","VER"}]
      
     Dim arrRes()
     ReDim arrRes(1 To UBound(arrSrc), 1 To UBound(arrSrc, 2))
     r = 1
     For i = 1 To UBound(arrSrc)
         If i = 1 Then
             For j = 1 To UBound(ColNames)
                 arrRes(r, j) = ColNames(j)
             Next j
             r = r + 1
         ElseIf Not arrSrc(i, 6) = "" Then
             For j = 1 To UBound(arrSrc, 2)
                 Data = ""
                 Select Case j
                     Case 1
                         Data = "17"
                     Case 4
                         Data = "11"
                     Case 7
                         Data = "11"
                     Case 13
                         Data = "00"
                     Case 27
                         Data = "1"
                     Case 12
                         ' умножение на 1000
                         Data = Val(arrSrc(i, j)) * 1000
                     Case Else
                         Data = arrSrc(i, j)
                 End Select
                  
                 arrRes(r, j) = Data
             Next j
             r = r + 1
         End If
     Next i
      
     Dim New_Wb As Workbook
     Set New_Wb = Workbooks.Add
     New_Wb.ActiveSheet.Range("A1").Resize(UBound(arrRes), UBound(arrRes, 2)).Value = arrRes
     New_Wb.SaveAs Filename:=ThisWorkbook.Path & "\maket17_ms21.xlsx"
     MsgBox "Макет 17 для МС21 успешно сформирован"
End Sub
[/vba]
Файл поместите в одну папку с "ms21.xlsx" и нажмите кнопку
Автор - miver
Дата добавления - 23.09.2015 в 11:20
cresh12 Дата: Среда, 23.09.2015, 11:34 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
miver, Спасибо, но подскажите пожалуйста что нужно изменить чтобы информация копировалась с некоторым соответствием: например из 2 столбца исходной книги в 5 столбец новой, из 23 в 15?
 
Ответить
Сообщениеmiver, Спасибо, но подскажите пожалуйста что нужно изменить чтобы информация копировалась с некоторым соответствием: например из 2 столбца исходной книги в 5 столбец новой, из 23 в 15?
Автор - cresh12
Дата добавления - 23.09.2015 в 11:34
miver Дата: Среда, 23.09.2015, 12:10 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 190
Репутация: 37 ±
Замечаний: 0% ±

Excel 2010
Просто добавте правило при переборе исходных столбиков
[vba]
Код
                Select Case j
                       Case 5
                           Data = arrSrc(i, 2)
                       Case 15
                           Data = arrSrc(i, 23)
                       Case 1
                           Data = "17"
                       Case 4
                           Data = "11"
                       Case 7
                           Data = "11"
                       Case 13
                           Data = "00"
                       Case 27
                           Data = "1"
                       Case 12
                           ' умножение на 1000
                           Data = Val(arrSrc(i, j)) * 1000
                       Case Else
                           Data = arrSrc(i, j)
                   End Select
[/vba]
Немного перепутал индексы


Сообщение отредактировал miver - Среда, 23.09.2015, 12:15
 
Ответить
СообщениеПросто добавте правило при переборе исходных столбиков
[vba]
Код
                Select Case j
                       Case 5
                           Data = arrSrc(i, 2)
                       Case 15
                           Data = arrSrc(i, 23)
                       Case 1
                           Data = "17"
                       Case 4
                           Data = "11"
                       Case 7
                           Data = "11"
                       Case 13
                           Data = "00"
                       Case 27
                           Data = "1"
                       Case 12
                           ' умножение на 1000
                           Data = Val(arrSrc(i, j)) * 1000
                       Case Else
                           Data = arrSrc(i, j)
                   End Select
[/vba]
Немного перепутал индексы
Автор - miver
Дата добавления - 23.09.2015 в 12:10
cresh12 Дата: Среда, 23.09.2015, 13:41 | Сообщение № 10
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
miver, Это гениально)) Спасибо большое)) Только один недостаток есть, при умножении на 1000 в тех ячейках где целое число все происходит без проблем, а там где дробь, например 0,235, то число обнуляется(
 
Ответить
Сообщениеmiver, Это гениально)) Спасибо большое)) Только один недостаток есть, при умножении на 1000 в тех ячейках где целое число все происходит без проблем, а там где дробь, например 0,235, то число обнуляется(
Автор - cresh12
Дата добавления - 23.09.2015 в 13:41
Roman777 Дата: Среда, 23.09.2015, 13:55 | Сообщение № 11
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
cresh12, попробуйте вместо
[vba]
Код
Data = Val(arrSrc(i, j)) * 1000
[/vba]

[vba]
Код
Data = (arrSrc(i, j)) * 1000
[/vba]

Много чего не знаю!!!!
 
Ответить
Сообщениеcresh12, попробуйте вместо
[vba]
Код
Data = Val(arrSrc(i, j)) * 1000
[/vba]

[vba]
Код
Data = (arrSrc(i, j)) * 1000
[/vba]
Автор - Roman777
Дата добавления - 23.09.2015 в 13:55
Roman777 Дата: Среда, 23.09.2015, 13:56 | Сообщение № 12
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
miver,
что такое эта функция Val? я понимаю что это типа Value, но не пойму зачем она тут?

Много чего не знаю!!!!
 
Ответить
Сообщениеmiver,
что такое эта функция Val? я понимаю что это типа Value, но не пойму зачем она тут?
Автор - Roman777
Дата добавления - 23.09.2015 в 13:56
cresh12 Дата: Среда, 23.09.2015, 13:58 | Сообщение № 13
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Roman777, ох, действительно дело было в Val, спасибо)))
 
Ответить
СообщениеRoman777, ох, действительно дело было в Val, спасибо)))
Автор - cresh12
Дата добавления - 23.09.2015 в 13:58
cresh12 Дата: Среда, 23.09.2015, 14:27 | Сообщение № 14
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Прошу прощения, что надоедаю, но возник такой вопрос, возможно ли заменить конструкцию чтобы было по красивей?)
[vba]
Код
        Case 14
                     If arrSrc(i, 22) <> "" Then Data = arrSrc(i, 25) Else Data = "00"
                           Case 15
                     If arrSrc(i, 22) <> "" Then Data = arrSrc(i, 26) Else Data = "0000000"
                           Case 16
                     If arrSrc(i, 22) <> "" Then Data = arrSrc(i, 29) * 1000 Else Data = "000000000"
                           Case 17
                     If arrSrc(i, 22) <> "" Then Data = arrSrc(i, 35) Else Data = "000"
[/vba]
пробовал использовать Select Case, но т.к. необходимо несколько Else она не заработала)
Отбой, все прекрасно работает и так. p.s. не знаю как удалить сообщение


Сообщение отредактировал cresh12 - Среда, 23.09.2015, 15:02
 
Ответить
СообщениеПрошу прощения, что надоедаю, но возник такой вопрос, возможно ли заменить конструкцию чтобы было по красивей?)
[vba]
Код
        Case 14
                     If arrSrc(i, 22) <> "" Then Data = arrSrc(i, 25) Else Data = "00"
                           Case 15
                     If arrSrc(i, 22) <> "" Then Data = arrSrc(i, 26) Else Data = "0000000"
                           Case 16
                     If arrSrc(i, 22) <> "" Then Data = arrSrc(i, 29) * 1000 Else Data = "000000000"
                           Case 17
                     If arrSrc(i, 22) <> "" Then Data = arrSrc(i, 35) Else Data = "000"
[/vba]
пробовал использовать Select Case, но т.к. необходимо несколько Else она не заработала)
Отбой, все прекрасно работает и так. p.s. не знаю как удалить сообщение
Автор - cresh12
Дата добавления - 23.09.2015 в 14:27
miver Дата: Среда, 23.09.2015, 15:47 | Сообщение № 15
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 190
Репутация: 37 ±
Замечаний: 0% ±

Excel 2010
Цитата Roman777, 23.09.2015 в 13:56, в сообщении № 12
что такое эта функция Val?
Преобразует любое значение в целое число. Даже если подставить строку, будет старатся преобразовать в число и не выдает ошибок ;)
Val описание

Цитата cresh12, 23.09.2015 в 14:27, в сообщении № 14
возможно ли заменить конструкцию
Можно попробовать так
[vba]
Код
Data = IIf(arrSrc(i, 22) = "", "'00", arrSrc(i, 25))
[/vba]

[p.s.]Если хотите вставлять "00" в виде текста, то лучше ставить знак апострофа перед строкой - "'00". Excel часто преобразует строку в число и может отобразить - 0
 
Ответить
Сообщение
Цитата Roman777, 23.09.2015 в 13:56, в сообщении № 12
что такое эта функция Val?
Преобразует любое значение в целое число. Даже если подставить строку, будет старатся преобразовать в число и не выдает ошибок ;)
Val описание

Цитата cresh12, 23.09.2015 в 14:27, в сообщении № 14
возможно ли заменить конструкцию
Можно попробовать так
[vba]
Код
Data = IIf(arrSrc(i, 22) = "", "'00", arrSrc(i, 25))
[/vba]

[p.s.]Если хотите вставлять "00" в виде текста, то лучше ставить знак апострофа перед строкой - "'00". Excel часто преобразует строку в число и может отобразить - 0
Автор - miver
Дата добавления - 23.09.2015 в 15:47
cresh12 Дата: Среда, 23.09.2015, 15:53 | Сообщение № 16
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
miver,
Цитата miver, 23.09.2015 в 15:47, в сообщении № 15
Если хотите вставлять "00" в виде текста, то лучше ставить знак апострофа перед строкой - "'00". Excel часто преобразует строку в число и может отобразить - 0

Отдельная благодарность за такой простой способ, а то все думал как сделать весь лист в текстовом формате:)
Не сочтите за наглость, а не подскажите как сделать чтобы пустые строки заполнить нулями в нужном количестве, например 000?)
 
Ответить
Сообщениеmiver,
Цитата miver, 23.09.2015 в 15:47, в сообщении № 15
Если хотите вставлять "00" в виде текста, то лучше ставить знак апострофа перед строкой - "'00". Excel часто преобразует строку в число и может отобразить - 0

Отдельная благодарность за такой простой способ, а то все думал как сделать весь лист в текстовом формате:)
Не сочтите за наглость, а не подскажите как сделать чтобы пустые строки заполнить нулями в нужном количестве, например 000?)
Автор - cresh12
Дата добавления - 23.09.2015 в 15:53
miver Дата: Среда, 23.09.2015, 16:02 | Сообщение № 17
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 190
Репутация: 37 ±
Замечаний: 0% ±

Excel 2010
cresh12, Почитайте про функцию String
 
Ответить
Сообщениеcresh12, Почитайте про функцию String
Автор - miver
Дата добавления - 23.09.2015 в 16:02
Pelena Дата: Среда, 23.09.2015, 16:03 | Сообщение № 18
Группа: Админы
Ранг: Местный житель
Сообщений: 19603
Репутация: 4660 ±
Замечаний: ±

Excel 365 & Mac Excel
cresh12, не надо сваливать все вопросы в одну тему. Читайте Правила форума

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
Сообщениеcresh12, не надо сваливать все вопросы в одну тему. Читайте Правила форума
Автор - Pelena
Дата добавления - 23.09.2015 в 16:03
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Проверка столбцов перед копированием и последуещее умножение (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2026 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!