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
