Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1 2 След.
RSS
Перенос данных из вертикальной таблицы в горизонтальную. Помогите :(((
 
#1
17.01.2012 14:34:22
Добрый день.  
 
Помогите пожалуйста мне с моей проблемой.  
 
Есть две таблицы на листе. Одна заполняется вертикально, вторая горизонтально. Также есть две кнопки, первая - "Внести данные", вторая - "Удалить пустую строку".  
   
В первой таблице 4 пункта: ФИО, Номер, должность, и статус.  
Во второй таблице те же 4 пункта, но есть ещё и дополнительный - это порядковый номер (№ п/п).  
 
Подскажите мне как должен выглядить макрос, чтобы при нажатии кнопки "Внести данные", данные из вертикальной таблицы заполнялись в горизонтальную на последнюю пустую строку. И при этом присваивался правильный номер по порядку в графу № п/п.  
 
А при нажатии кнопки "Удалить последнюю строку" удалялась последняя заполненая строка в горизонтальной таблице.  
 
Вот такая проблема у меня :(((( Помогите кто может
 
 
 
#2
17.01.2012 14:44:16
Ребят, подскажите а((((
 
 
 
#3
17.01.2012 14:45:08
Макрос должен выглядеть красиво!  
А вот как выглядит Ваш файл - нам неведомо...
 
 
 
#4
17.01.2012 14:51:36
{quote}{login=Hugo}{date=17.01.2012 02:45}{thema=}{post}Макрос должен выглядеть красиво!  
А вот как выглядит Ваш файл - нам неведомо...{/post}{/quote}  
 
Я пример смогу только вечером выложить :(  
 
Ну примерно же можно представить, таблица 4 строки и 2 столбца. В ней по вертикали в первом столбце 4 пункта: ФИО, должность, номер, статус.  
 
Горизонтальная таблица с 5 столбцами. Такие же графы только ещё и № п/п.
 
 
 
#5
17.01.2012 15:05:10
Примерно я представил.  
Но макросу нужно конкретно.  
Можем свой пример сделать.  
Можем потом весь код переписывать под Ваш пример.  
Но не хотим.
 
 
 
#6
17.01.2012 15:07:47
{quote}{login=Hugo}{date=17.01.2012 03:05}{thema=}{post}Примерно я представил.  
Но макросу нужно конкретно.  
Можем свой пример сделать.  
Можем потом весь код переписывать под Ваш пример.  
Но не хотим.{/post}{/quote}  
 
Хьюго, мне бы хоть Ваш пример. Я только начала изучать язык вба. Мне для примера хоть.
 
 
 
#7
17.01.2012 15:14:28
{quote}{login=Елена Вилонова}{date=17.01.2012 02:51}{thema=Re: }{post}{quote}{login=Hugo}{date=17.01.2012 02:45}{thema=}{post}{/post}{/quote}Я пример смогу только вечером выложить{/post}{/quote}У Вас не установлен Excel? Как же Вы посмотрите пример? Если Excel есть - создайте небольшой файл-пример.
 
 
 
#8
17.01.2012 15:15:43
{quote}{login=Юрий М}{date=17.01.2012 03:14}{thema=Re: Re: }{post}{quote}{login=Елена Вилонова}{date=17.01.2012 02:51}{thema=Re: }{post}{quote}{login=Hugo}{date=17.01.2012 02:45}{thema=}{post}{/post}{/quote}Я пример смогу только вечером выложить{/post}{/quote}У Вас не установлен Excel? Как же Вы посмотрите пример? Если Excel есть - создайте небольшой файл-пример.{/post}{/quote}  
 
Ну я же говорю, только вечером смогу дать пример или посмотреть. :(
 
 
 
#9
17.01.2012 15:33:10
Не, так лениво... Ещё и файл рисовать...  
Могу свой алгоритм на словах описать.  
1. Ищем последнюю занятую строку второй таблицы.  
Например вроде этого - смотря что нужно:  
 
With Sheets(1)  
.Cells(.Rows.Count, "A").End(xlUp)(1).Select  
.[A1].End(xlDown)(2).Select
End With  
 
Select только для примера, в коде он не нужен.  
Нужный диапазон можно получить с помощью Set и Resize.  
Или работаем с номерами строк Cells(n, m)  
 
2. Если нужно удалить, т.е. очистить - очищаем.  
3. Если нужно добавить данные - добавляем из второй таблицы (где там что - заранее известно).  
Порядковый номер можно получить, отняв нужное число от номера строки рабочего диапазона.
 
 
 
#10
17.01.2012 15:37:50
Топор и напильник  
Sub Макрос1()  
'  
' Макрос1 Макрос  
'  
 
'  
   Range("E2").Select  
   ActiveCell.FormulaR1C1 = "=R[-1]C+1"
   Range("A1:A4").Select  
   Selection.Copy  
   Range("F2").Select  
   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _  
       False, Transpose:=True  
   Range("A1:A4").Select  
   Application.CutCopyMode = False  
   Selection.ClearContents  
End Sub  
 
Sub qqq()  
   Cells(Rows.Count, "E").End(xlUp).Offset(1) = Val(Cells(Rows.Count, "E").End(xlUp)) + 1  
   Range("A1:A4").Copy  
   Cells(Rows.Count, "E").End(xlUp).Offset(, 1).PasteSpecial Paste:=xlPasteAll, _  
                                                           Operation:=xlNone, SkipBlanks:=False, Transpose:=True  
   Range("A1:A4").ClearContents  
   Application.CutCopyMode = False  
End Sub
 
 
 
#11
18.01.2012 07:10:40
Ребята, вот файл с примером. Я до сих пор не могу сделать. Ваши примеры пробовала вставлять, но никак не получается(((
 
 
 
#12
18.01.2012 08:47:32
С моим примитивным знанием VBA смог что смог.  
 
Конечно если я правильно понял )))
 
 
 
#13
18.01.2012 09:49:15
Или так.
 
 
 
#14
18.01.2012 10:01:11
А кто просил "хоть проиер"?
 
 
 
#15
18.01.2012 10:49:15
Мужики прикрутите этот макрос и мне пожалуйста для моего примера. Чето ковыряюсь и никак не могу этого сделать нормально.  
<EM><STRONG>Файл удален</STRONG> - велик размер - [<STRONG>МОДЕРАТОРЫ</STRONG>]</EM>
 
 
 
#16
18.01.2012 11:18:41
Мужики выручите пожалуйста  
<EM><STRONG>мало того, что в чужой теме,</STRONG>так еще и ГОРИТ!!! Вам что тут, быстрорешалка? [<STRONG>МОДЕРАТОРЫ</STRONG>]</EM>
 
 
 
#17
18.01.2012 11:28:14
Что непонятно в коде post_298010.xls?  
Лениво код писать?
 
 
 
#18
18.01.2012 12:11:51
Мужики, я вот написал кое че в макросе. Вроде работает, но не так как нужно.    
 
Что нужно сделать чтобы заполнение началиналось с 24 строки. А то у меня получается сразу после надписей в шапке.  
 
И как можно ограничить удаление чтобы выше 24 строки не удалялось?  
 
Вложил свою работу.  
<EM><STRONG>Файл удален</STRONG> - велик размер - [<STRONG>МОДЕРАТОРЫ</STRONG>]</EM>
 
 
 
#19
18.01.2012 12:26:17
Пользователь1365, Один Ваш файл уже удалили с указанием причины. Вы читать умеете? С Правилами ознакомились?
 
 
 
#20
18.01.2012 12:33:57
{quote}{login=Юрий М}{date=18.01.2012 12:26}{thema=}{post}Пользователь1365, Один Ваш файл уже удалили с указанием причины. Вы читать умеете? С Правилами ознакомились?{/post}{/quote}  
 
Извините, Юрий. Моя ошибка.  
 
Но все же помогите довести код до ума. Вопросов только прибавляется(  
 
1) Что нужно сделать чтобы заполнение началиналось с 24 строки. А то у меня получается сразу после надписей в шапке.  
 
2) И как можно ограничить удаление чтобы выше 24 строки не удалялось?  
 
3) Как исправить код чтобы заполнение шло так же из областей I5:I14 и D5:D14  ?
 
 
 
#21
18.01.2012 12:35:35
Вкладываю файл:
 
 
 
#22
18.01.2012 13:03:03
1) Самое простое - впишите в B23 что-то жёлтым шрифтом  
 
2)  
Sub del_Row()  
If Cells(Rows.Count, "B").End(xlUp).Row > 23 Then _  
Cells(Rows.Count, "B").End(xlUp).EntireRow.ClearContents  
End Sub  
 
3). Продублируйте с коррекцией:  
 
Sub qqq()  
Cells(Rows.Count, "B").End(xlUp).Offset(1) = Val(Cells(Rows.Count, "B").End(xlUp)) + 1  
Range("D5:D13").Copy  
Cells(Rows.Count, "B").End(xlUp).Offset(, 1).PasteSpecial Paste:=xlPasteAll, _  
Operation:=xlNone, SkipBlanks:=False, Transpose:=True  
 
Range("I5:I14").Copy  
Cells(Rows.Count, "B").End(xlUp).Offset(, 10).PasteSpecial Paste:=xlPasteAll, _  
Operation:=xlNone, SkipBlanks:=False, Transpose:=True  
 
Range("L5:l14").Copy  
Cells(Rows.Count, "B").End(xlUp).Offset(, 20).PasteSpecial Paste:=xlPasteAll, _  
Operation:=xlNone, SkipBlanks:=False, Transpose:=True  
 
Application.CutCopyMode = False  
End Sub  
 
 
Но я форматы бы не копировал.  
Ну и ещё проверку бы сперва добавить, что всё вверху заполнено как нужно.
 
 
 
#23
18.01.2012 13:13:25
{quote}{login=Hugo}{date=18.01.2012 01:03}{thema=}{post}1) Самое простое - впишите в B23 что-то жёлтым шрифтом  
 
2)  
Sub del_Row()  
If Cells(Rows.Count, "B").End(xlUp).Row > 23 Then _  
Cells(Rows.Count, "B").End(xlUp).EntireRow.ClearContents  
End Sub  
 
3). Продублируйте с коррекцией:  
 
Sub qqq()  
Cells(Rows.Count, "B").End(xlUp).Offset(1) = Val(Cells(Rows.Count, "B").End(xlUp)) + 1  
Range("D5:D13").Copy  
Cells(Rows.Count, "B").End(xlUp).Offset(, 1).PasteSpecial Paste:=xlPasteAll, _  
Operation:=xlNone, SkipBlanks:=False, Transpose:=True  
 
Range("I5:I14").Copy  
Cells(Rows.Count, "B").End(xlUp).Offset(, 10).PasteSpecial Paste:=xlPasteAll, _  
Operation:=xlNone, SkipBlanks:=False, Transpose:=True  
 
Range("L5:l14").Copy  
Cells(Rows.Count, "B").End(xlUp).Offset(, 20).PasteSpecial Paste:=xlPasteAll, _  
Operation:=xlNone, SkipBlanks:=False, Transpose:=True  
 
Application.CutCopyMode = False  
End Sub  
 
 
Но я форматы бы не копировал.  
Ну и ещё проверку бы сперва добавить, что всё вверху заполнено как нужно.{/post}{/quote}  
 
А как сделать чтобы копировалось только значения ячеек? А то действительно копируется формат, что не очень нужно.
 
 
 
#24
18.01.2012 13:46:52
Замените  
xlPasteAll  
на  
xlPasteValues  
 
 
Ну и в конце кода ещё ативируйте начало листа - как-то неудобно, что в конце остаётся активная ячейка.
 
 
 
#25
18.01.2012 14:45:58
Без форматов  
Sub qqq()  
Dim i&  
Cells(Rows.Count, "B").End(xlUp).Offset(1) = Val(Cells(Rows.Count, "B").End(xlUp)) + 1  
i = Cells(Rows.Count, "B").End(xlUp).Row  
Range("C" & i).Resize(, 9) = Application.Transpose([D5:D13])
Range("L" & i).Resize(, 10) = Application.Transpose([I5:I14])
Range("V" & i).Resize(, 10) = Application.Transpose([L5:L14])
End Sub
 
 
 
#26
19.01.2012 07:44:00
{quote}{login=RAN}{date=18.01.2012 02:45}{thema=}{post}Без форматов  
Sub qqq()  
Dim i&  
Cells(Rows.Count, "B").End(xlUp).Offset(1) = Val(Cells(Rows.Count, "B").End(xlUp)) + 1  
i = Cells(Rows.Count, "B").End(xlUp).Row  
Range("C" & i).Resize(, 9) = Application.Transpose([D5:D13])
Range("L" & i).Resize(, 10) = Application.Transpose([I5:I14])
Range("V" & i).Resize(, 10) = Application.Transpose([L5:L14])
End Sub{/post}{/quote}  
 
Прикрутил себе такой же способ заполнения. Заметил что при выставлении нумерации в графе "№ п/п" формат текста не присваивается.  
 
Но требуется чтобы присваивался текстовый формат ячейкам столбца 2 (№ п/п тобиш). Ибо к этому столбцу прикручен текстбокс с автофильтром.  
 
Как быть? Как прописать чтобы при заполнении ячейке присваивался текстовый формат?
 
 
 
#27
19.01.2012 08:33:48
Мужики, помогите разобраться :)
 
 
 
#28
19.01.2012 09:01:11
Дорогие форумчане, мастера своего дела! :) Помогите уж нубу то разобраться в этом нелегком деле(
 
 
 
#29
19.01.2012 09:32:14
Sub ss()  
Columns(2).SpecialCells(xlCellTypeConstants).NumberFormat = "@"  
End Sub
 
 
 
#30
19.01.2012 09:54:10
{quote}{login=k61}{date=19.01.2012 09:32}{thema=re: Нубасик}{post}Sub ss()  
Columns(2).SpecialCells(xlCellTypeConstants).NumberFormat = "@"  
End Sub{/post}{/quote}  
 
Sub Âíåñòè_äàííûå_Áàçà_äàííûõ()  
Application.ScreenUpdating = False  
 
     
   If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData  
             
   Columns("A:A").Select  
   Selection.ClearContents  
   Range("A22").Select  
     
         
Cells(Rows.Count, "B").End(xlUp).Offset(1) = Val(Cells(Rows.Count, "B").End(xlUp)) + 1  
Range("D5:D13").Copy  
Cells(Rows.Count, "B").End(xlUp).Offset(, 1).PasteSpecial Paste:=xlPasteValues, _  
Operation:=xlNone, SkipBlanks:=False, Transpose:=True  
 
Range("I5:I14").Copy  
Cells(Rows.Count, "B").End(xlUp).Offset(, 10).PasteSpecial Paste:=xlPasteValues, _  
Operation:=xlNone, SkipBlanks:=False, Transpose:=True  
 
Range("L5:l14").Copy  
Cells(Rows.Count, "B").End(xlUp).Offset(, 20).PasteSpecial Paste:=xlPasteValues, _  
Operation:=xlNone, SkipBlanks:=False, Transpose:=True  
 
Range("D5").Select  
Application.CutCopyMode = False  
 
 
 
Columns(2).SpecialCells(xlCellTypeConstants).NumberFormat = "@"  
 
 
 
Application.ScreenUpdating = True  
End Sub  
 
 
Вот попытался внедрить в код. Но всё равно не работает. Как быть?
 
 
 
Страницы: 1 2 След.
Читают тему
Наверх