Здраейте, имам нужда от следната помощ
в папка 042008 имам към 20 екселски файла, в всеки от които им апо 2 шиита с точни имена едната се казва А а другата Б, искам да обединя информацията в нов файл, които също да съдържа шеет А и шеет Б, като шеет А е директно копиране на всичките 20 файла каквото те съдържат в шеет А, и съответното за шеет Б - що за макрос трябва да ползвам?
Благодаря предварително за помощта

Редактирано от ax4o на 25.06.08 11:10.

По-долу е процедурата. Само там където имаш

firstWS = "A"
secondWS = "B"

замени A и B с имената на двата листа, които искаш да копираш

' Кодът започва тук

Sub CopyFilesInDir()

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.BrowseForFolder(0, "Select Folder", 0, 0)

If (Not objFolder Is Nothing) Then
On Error Resume Next
If IsError(objFolder.Items.Item.Path) Then MyDir = _
CStr(objFolder): GoTo Here
On Error GoTo 0

If Len(objFolder.Items.Item.Path) > 3 Then
MyDir = objFolder.Items.Item.Path & _
Application.PathSeparator
Else
MyDir = objFolder.Items.Item.Path
End If
Else: Application.ScreenUpdating = True: End
End If
Here:
Set objFolder = Nothing: Set objShell = Nothing


firstWS = "A"
secondWS = "B"

Set MyNewFile = Workbooks.Add



Set MyWS = MyNewFile.Worksheets.Add
MyWS.Name = secondWS

Set MyWS = MyNewFile.Worksheets.Add
MyWS.Name = firstWS


MyFileName = Dir(MyDir, 7)



Do While MyFileName <> ""
MyFile = MyDir & MyFileName

Set wb = Workbooks.Open(MyFile)

a = True
B = True




On Error Resume Next

wb.Worksheets(firstWS).Activate

If Err <> 0 Then
a = False
MsgBox ("В този файл няма лист " & firstWS & ". Затварям файла без копиране.")
wb.Close
End If

If a Then
wb.Worksheets(secondWS).Activate
If Err <> 0 Then
B = False
MsgBox ("В този файл няма лист " & secondWS & "Затварям файла без копиране.")
wb.Close
End If

On Error GoTo 0

If a And B Then
Application.ScreenUpdating = False
LastRow = wb.Worksheets(firstWS).Range("A65536").End(xlUp).Row
LastRow1 = MyNewFile.Worksheets(firstWS).Range("A65536").End(xlUp).Row
If LastRow1 > 1 Then LastRow1 = LastRow1 + 1

MyRange = "1:" & LastRow

wb.Worksheets(firstWS).Rows(MyRange).Copy

MyNewFile.Worksheets(firstWS).Rows(LastRow1).PasteSpecial


LastRow = wb.Worksheets(secondWS).Range("A65536").End(xlUp).Row
LastRow1 = MyNewFile.Worksheets(secondWS).Range("A65536").End(xlUp).Row
If LastRow1 > 1 Then LastRow1 = LastRow1 + 1

MyRange = "1:" & LastRow



wb.Worksheets(secondWS).Rows(MyRange).Copy

MyNewFile.Worksheets(secondWS).Rows(LastRow1).PasteSpecial

Application.ScreenUpdating = True

wb.Close


End If
End If


MyFileName = Dir()



Loop

Worksheets(secondWS).Activate
Cells(1, 1).Activate

Worksheets(firstWS).Activate
Cells(1, 1).Activate

Do
fName = Application.GetSaveAsFilename
Loop Until fName <> False

If Right(fName, 4) <> ".xls" Then fName = fName & ".xls"
MyNewFile.SaveAs Filename:=fName

End Sub

' Кодът свършва тук

Съдържаниет е скрито
Влезте за да го видите

справи ли се ако не изпрати ми файловете кажи какво къде искаш да копираш и ще ти напиша макросче. Правил съм го но малко по различно , дори в единия шийт ще ти направя и списък на файлчета.
Пиши тук и ще ти дам моя адрес

Благодаря за бързия отговор и работещо решение, сега само требе да махна първият ред от всеки лист и е готово.

Човърках се, но намерих само два примера за изтриване на празните редове в този клуб, но нито един не ми върши работа тъй като трябва да правя проверка ако стойността в колона г(2-последният писан ред)=0 или няма стойност от лист Б да не ги копира в новосъздаденият лист Б

Още венъж Благодаря боби. Имаш интересен блог

Съдържаниет е скрито
Влезте за да го видите

Редактирано от ax4o на 26.06.08 11:54.

Ако правилно съм те разбрал, имаш антетка в първия ред на всеки лист, така ли?
всъщност не съобразих, ама и ти не беше казал... :-) ако е това пипни кода, който ти пуснах.
Редовете

MyRange = "1:" & LastRow

Трябва да станат

MyRange = "2:" & LastRow

Така няма да копира първия ред от всеки лист


Другото за проверката не го разбрах нещо... Трябва ако колона G в последния ред е 0 или празно, да не копира нищо от този лист, така ли? А с лист а какво става в този случай?
освен това, ако е ясно коя е последната колона ( примерно трябва да се копират само колони от A до G, може да се поправи, за да не копира целия ред) ще работи по-бързо, а и няма да те пита за clipboarda

Съдържаниет е скрито
Влезте за да го видите

Редактирано от Бypaн на 26.06.08 12:11.

Ами и в А лист сами излишни празните стойности но там са 4 колони в които в която и от тях да има запис различен от 0 или нищо трябва да остават. Но мога да променя ако в колона Е няма запис да се изтрива
лист А се попълват колони от А до Й (джей), а в лист Б колони от А до Г.
Сетих се за MyRange = "2:" & LastRow - работи.

Сложи този код:

MyNewFile.Activate

i = 1
Do

If Worksheets(firstWS).Cells(i, 5).Value = "" Or _
Worksheets(firstWS).Cells(i, 5).Value = 0 Then
Worksheets(firstWS).Rows(i).Delete
LastRow = Worksheets(firstWS).Range("A65536").End(xlUp).Row
Else
i = i + 1
End If

Loop Until i > LastRow



i = 1
Do

If Worksheets(secondWS).Cells(i, 7).Value = "" Or _
Worksheets(secondWS).Cells(i, 7).Value = 0 Then
Worksheets(secondWS).Rows(i).Delete
LastRow = Worksheets(secondWS).Range("A65536").End(xlUp).Row
Else
i = i + 1
End If

Loop Until i > LastRow


След реда Loop - имам предвид този Loop който е непосредствено след MyFileName = Dir()
След като всичко е копирано прави проверка в лист а и лист Б на новия файл и итрива редовете в лист А, за които стойността в колона Е e нула или нищо, както и в лист B, там където в колона G e нула или нищо
Надявам се че няма проблем с кода, но ако има нещо - кажи

Съдържаниет е скрито
Влезте за да го видите

Благодаря работи перфектно!

И аз имам подобен случай за обединяване.Всяка таблица има два шийта, само че са наименувани различно, а на първата трябва да пише чл.3, на втората чл.3а.Трябва и да се вмъкнат три колони отпред и да се запише в тях съдържанието на F4,F6 и B6.