Hi, I made the following adjustment (marked with stars). It works fine. Do you see any error in code or possible improvements? I will make an addtional macro for: removing double entries + deleting rows with value=0 + sorting
My modification: ---------------------------------------------- Sub consolidatefromdifferentworkbooks() Application.DisplayAlerts = False 'On Error GoTo abc Dim ask As Workbook Dim ask2 As Workbook Dim ASK3 As Workbook Set ASK3 = ActiveWorkbook Dim i As Long Dim j As Long Dim N, z, r, s, k As Long s = 1 k = 1 Dim x As String Dim temp As String Sheets(1).Select Range("A65356").Select Selection.End(xlUp).Select r = ActiveCell.Row Workbooks.Open Filename:=ThisWorkbook.Sheets(1).Range("b2").Value Set ask = ActiveWorkbook For i = 2 To r 'Workbooks(Range("a" & i).Value).Windows(1).Visible = False ASK3.Activate Sheets(1).Select Workbooks.Open Filename:=Sheets(1).Range("a" & i).Value Set ask2 = ActiveWorkbook Sheets(1).Select Range("A1").Select ActiveCell.SpecialCells(xlLastCell).Select N = ActiveCell.Row If N >= 2 Then Rows("1:" & N).Select Selection.Copy 'Sheets.Add After:=Sheets(Sheets.Count) ask.Activate ask.Sheets(1).Activate Sheets(1).Select Range("A1").Select ActiveCell.SpecialCells(xlLastCell).Select *****************************z = ActiveCell.Row + 1***************************************** Range("A" & z).Select ***************************************Selection.PasteSpecial Paste:=xlPasteValues************************************** ActiveWorkbook.Save ask2.Activate ask2.Close End If Next i 'abc: 'Exit Sub Application.DisplayAlerts = True End Sub ---------------------------------------------------------- regards seba On 27 jan., 17:31, ashish koul <koul.ash...@gmail.com> wrote: > Sub consolidatefromdifferentworkbooks() > > Application.DisplayAlerts = False > 'On Error GoTo abc > Dim ask As Workbook > Dim ask2 As Workbook > Dim ASK3 As Workbook > Set ASK3 = ActiveWorkbook > Dim i As Long > Dim j As Long > Dim N, z, r, s, k As Long > s = 1 > k = 1 > Dim x As String > Dim temp As String > > Sheets(1).Select > Range("A65356").Select > Selection.End(xlUp).Select > r = ActiveCell.Row > > Workbooks.Open Filename:=ThisWorkbook.Sheets(1).Range("b2").Value > Set ask = ActiveWorkbook > For i = 2 To r > > 'Workbooks(Range("a" & i).Value).Windows(1).Visible = False > > ASK3.Activate > Sheets(1).Select > Workbooks.Open Filename:=Sheets(1).Range("a" & i).Value > Set ask2 = ActiveWorkbook > * 'chnage sheet name here* > *Sheets("PRIPRAVA_PROJEKTA").Select > * > Range("A1").Select > > ActiveCell.SpecialCells(xlLastCell).Select > > N = ActiveCell.Row > If N >= 2 Then > > Rows("1:" & N).Select > > Selection.Copy > > 'Sheets.Add After:=Sheets(Sheets.Count) > ask.Activate > ask.Sheets(1).Activate > Sheets(1).Select > Range("A1").Select > ActiveCell.SpecialCells(xlLastCell).Select > > z = ActiveCell.Row + 2 > > Range("A" & z).Select > ActiveSheet.Paste > ActiveWorkbook.Save > ask2.Activate > ask2.Close > End If > > Next i > > 'abc: > 'Exit Sub > Application.DisplayAlerts = True > End Sub > > On Thu, Jan 27, 2011 at 9:57 PM, ashish koul <koul.ash...@gmail.com> wrote: > > > put sheetnames always in double quotes Sheets("PRIPRAVA_PROJEKTA"). > > > On Thu, Jan 27, 2011 at 9:23 PM, Seba <sebastjan.hri...@gmail.com> wrote: > > >> Hi, > > >> I made the following change for sheet name and I get the error > >> "Subscript out of range". Sheets(1) -> Sheets(PRIPRAVA_PROJEKTA) > > >> Sub consolidatefromdifferentworkbooks() > >> Application.DisplayAlerts = False > >> 'On Error GoTo abc > >> Dim ask As Workbook > >> Dim ask2 As Workbook > >> Dim ASK3 As Workbook > >> Set ASK3 = ActiveWorkbook > >> Dim i As Long > >> Dim j As Long > >> Dim N, z, r, s, k As Long > >> s = 1 > >> k = 1 > >> Dim x As String > >> Dim temp As String > > >> Sheets(1).Select > >> Range("A65356").Select > >> Selection.End(xlUp).Select > >> r = ActiveCell.Row > > >> Workbooks.Open Filename:=ThisWorkbook.Sheets(1).Range("b2").Value > >> Set ask = ActiveWorkbook > >> For i = 2 To r > > >> 'Workbooks(Range("a" & i).Value).Windows(1).Visible = False > >> ASK3.Activate > >> Sheets(PRIPRAVA_PROJEKTA).Select > >> Workbooks.Open Filename:=Sheets(PRIPRAVA_PROJEKTA).Range("a" & > >> i).Value > >> Set ask2 = ActiveWorkbook > >> Sheets(PRIPRAVA_PROJEKTA).Select > > >> Range("A1").Select > >> ActiveCell.SpecialCells(xlLastCell).Select > > >> N = ActiveCell.Row > >> If N >= 2 Then > >> Rows("1:" & N).Select > > >> Selection.Copy > > >> 'Sheets.Add After:=Sheets(Sheets.Count) > >> ask.Activate > >> ask.Sheets(1).Activate > >> Sheets(1).Select > >> Range("A1").Select > >> ActiveCell.SpecialCells(xlLastCell).Select > > >> z = ActiveCell.Row + 1 > > >> Range("A" & z).Select > >> ActiveSheet.Paste > >> ActiveWorkbook.Save > >> ask2.Activate > >> ask2.Close > >> End If > > >> Next i > >> 'abc: > >> 'Exit Sub > >> Application.DisplayAlerts = True > >> End Sub > > >> ------------------------- > >> regards > >> seba > > >> On 27 jan., 16:44, ashish koul <koul.ash...@gmail.com> wrote: > >> > shannur can you attch the sample workbook > > >> > On Thu, Jan 27, 2011 at 9:13 PM, ashish koul <koul.ash...@gmail.com> > >> wrote: > > >> > > use 2 for second sheet or 3 for 3 rd sheet like > >> > > sheets(2).select or you can also sheets("abc").select > > >> > > Workbooks.Open Filename:=Sheets(1).Range("a" & i).Value > >> > > Set ask2 = ActiveWorkbook > >> > > Sheets(1).Select > > >> > > @shannur can you send a sample workbook > > >> > > On Thu, Jan 27, 2011 at 9:04 PM, shannu shannu <shannur...@yahoo.com > >> >wrote: > > >> > >> Hi Ashish, > > >> > >> Life and death matter, I have a workbook and again it has diff sheets > >> like > >> > >> sheet 1 to sheet 11. and now my task is to copy unique names from > >> sheet 1 > >> > >> search in other sheets if it is existing then I need to copy only > >> those row > >> > >> from the diff sheets and create a fresh new workbook and name the > >> workbook > >> > >> with that name of the person > > >> > >> Regards, > >> > >> Shannur > > >> > >> --- On *Thu, 1/27/11, ashish koul <koul.ash...@gmail.com>* wrote: > > >> > >> From: ashish koul <koul.ash...@gmail.com> > > >> > >> Subject: Re: $$Excel-Macros$$ build a database from multiple > >> workbooks > >> > >> To: excel-macros@googlegroups.com > >> > >> Date: Thursday, January 27, 2011, 2:10 PM > > >> > >> On Thu, Jan 27, 2011 at 11:37 AM, ashish koul < > >> koul.ash...@gmail.com< > >> http://us.mc1200.mail.yahoo.com/mc/compose?to=koul.ash...@gmail.com> > >> > >> > wrote: > > >> > >> Sub consolidatefromdifferentworkbooks() > >> > >> Application.DisplayAlerts = False > >> > >> 'On Error GoTo abc > >> > >> Dim ask As Workbook > >> > >> Dim ask2 As Workbook > >> > >> Dim ASK3 As Workbook > >> > >> Set ASK3 = ActiveWorkbook > >> > >> Dim i As Long > >> > >> Dim j As Long > >> > >> Dim N, z, r, s, k, d As Long > >> > >> s = 1 > >> > >> k = 1 > >> > >> Dim x As String > >> > >> Dim temp As String > >> > >> Dim sht As Worksheet > > >> > >> Set ask2 = ActiveWorkbook > >> > >> Sheets(1).Select > >> > >> Range("A65356").Select > >> > >> Selection.End(xlUp).Select > >> > >> r = ActiveCell.Row > > >> > >> Workbooks.Open Filename:=ThisWorkbook.Sheets(1).Range("b2").Value > >> > >> Set ask = ActiveWorkbook > > >> > >> For i = 2 To r > >> > >> 'Workbooks(Range("a" & i).Value).Windows(1).Visible = False > >> > >> ASK3.Activate > >> > >> Sheets(1).Select > >> > >> Workbooks.Open Filename:=Sheets(1).Range("a" & i).Value > >> > >> Set ask2 = ActiveWorkbook > > >> > >> For d = 1 To ask2.Sheets.Count > >> > >> Sheets(d).Activate > >> > >> Sheets(d).Select > >> > >> Range("A1").Select > >> > >> ActiveCell.SpecialCells(xlLastCell).Select > > >> > >> ' Selection.End(xlToRight).Select > >> > >> ' > >> > >> ' > >> > >> 'temp = ActiveCell.Address > >> > >> 'x = Mid(temp, 2, (InStr(2, temp, "$") - 2)) > >> > >> ' > >> > >> ' > >> > >> ' > >> > >> ' Range("A65356").Select > >> > >> ' Selection.End(xlUp).Select > >> > >> N = ActiveCell.Row > >> > >> If N >= 2 Then > >> > >> Rows("1:" & N).Select > > >> > >> Selection.Copy > > >> > >> 'Sheets.Add After:=Sheets(Sheets.Count) > >> > >> ask.Activate > >> > >> ask.Sheets(1).Activate > >> > >> Sheets(1).Select > >> > >> Range("A1").Select > >> > >> ActiveCell.SpecialCells(xlLastCell).Select > > >> > >> z = ActiveCell.Row + 2 > > >> > >> Range("A" & z).Select > >> > >> ActiveSheet.Paste > >> > >> ActiveWorkbook.Save > >> > >> ask2.Activate > >> > >> End If > >> > >> Next d > >> > >> ask2.Activate > >> > >> ask2.Close > > >> > >> ask.Activate > >> > >> ask.Sheets(1).Activate > > >> > >> ActiveWorkbook.Save > >> > >> Next i > >> > >> 'abc: > >> > >> 'Exit Sub > >> > >> Application.DisplayAlerts = True > >> > >> End Sub > > >> > >> On Thu, Jan 27, 2011 at 11:23 AM, Squall <squall.l...@gmail.com< > >> http://us.mc1200.mail.yahoo.com/mc/compose?to=squall.l...@gmail.com> > >> > >> > wrote: > > >> > >> Hi guys, > > >> > >> Could you please share us the coding especially when helping... it > >> really > >> > >> help to improve those being helped (especially me) to understand the > >> vba > >> > >> macro/coding. Sometimes when I try to open the module/code, it's > >> protected > >> > >> by password :( > > >> > >> Nonetheless, thanks for the help. > > >> > >> On 1/26/2011 10:33 PM, ashish koul wrote: > > >> > >> try this macro see if it helps > > >> > >> On Wed, Jan 26, 2011 at 4:22 PM, Seba <sebastjan.hri...@gmail.com< > >> http://us.mc1200.mail.yahoo.com/mc/compose?to=sebastjan.hri...@gmail.com> > >> > >> > wrote: > > >> > >> Hello, > > >> > >> how can I upload the file, as I see in the notification, this is no > >> > >> longer possible. > > >> > >> However, if you can imagine my situation: > > >> > >> I have data in columns from A to O and in rows from 1 to 100. The > >> data > >> > >> is in the same rows and columns in all workbooks. > >> > >> Now I need the data to be copied from all this workbooks (and all new > >> > >> ones I create) to a new workbook serving as a database. > > >> > >> However all columns allways contain some data, whereas the rows may > >> > >> not. It could be the case that only the 1st row contains any data. > > >> > >> I hope this helps a bit. > > >> > >> Thank you for the help. > > >> > >> Best regards, > > >> > >> seba > > >> > >> On 17 jan., 18:38, ashish koul <koul.ash...@gmail.com< > >> http://us.mc1200.mail.yahoo.com/mc/compose?to=koul.ash...@gmail.com>> > >> > >> wrote: > >> > >> > send us the sample workbook > > >> > >> > On Mon, Jan 17, 2011 at 12:10 AM, Seba <sebastjan.hri...@gmail.com > >> <http://us.mc1200.mail.yahoo.com/mc/compose?to=sebastjan.hri...@gmail.com > > >> > >> wrote: > >> > >> > > Hello all, > > >> > >> > > I have a question regarding building a database. I have a > >> workbook for > >> > >> > > each of my projects. I would like to have a macro, which would > >> > >> extract/ > >> > >> > > copy certain data (always in the same rows and columns) to a new > >> > >> > > workbook, which would serve as a database. > > >> > >> > > Could anyone please help? > > >> > >> > > Thank you in advance. > > >> > >> > > Best regards, > > >> > >> > > seba > > >> > >> > > -- > > >> ---------------------------------------------------------------------------------- > >> > >> > > Some important links for excel users: > >> > >> > > 1. Follow us on TWITTER for tips tricks and links : > >> > >> > >http://twitter.com/exceldailytip > >> > >> > > 2. Join our LinkedIN group @ > >> > >>http://www.linkedin.com/groups?gid=1871310 > >> > >> > > 3. Excel tutorials athttp://www.excel-macros.blogspot.com > >> > >> > > 4. Learn VBA Macros athttp://www.quickvba.blogspot.com > >> > >> > > 5. Excel Tips and Tricks athttp://exceldailytip.blogspot.com > > >> > >> > > To post to this group, send email to > >> excel-macros@googlegroups.com< > >>http://us.mc1200.mail.yahoo.com/mc/compose?to=excel-macros@googlegrou...> > > >> > >> > > <><><><><><><><><><><><><><><><><><><><><><> > >> > >> > > Like our page on facebook , Just follow below link > > ... > > preberite več » -- ---------------------------------------------------------------------------------- Some important links for excel users: 1. Follow us on TWITTER for tips tricks and links : http://twitter.com/exceldailytip 2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310 3. Excel tutorials at http://www.excel-macros.blogspot.com 4. Learn VBA Macros at http://www.quickvba.blogspot.com 5. Excel Tips and Tricks at http://exceldailytip.blogspot.com To post to this group, send email to excel-macros@googlegroups.com <><><><><><><><><><><><><><><><><><><><><><> Like our page on facebook , Just follow below link http://www.facebook.com/discussexcel