My latest project

m_in_spain

Board Regular
Joined
Sep 28, 2018
Messages
55
Hello again,
My latest project involves opening another workbook (workbook B), getting the worksheet names, copying them to a list on a sheet ("Main") in workbook A, then creating the same worksheets in workbook A. I have managed to sort this out by scratching around on the internet and putting the following together:
VBA Code:
Sub Everything()
Dim mySh As Worksheet, Ws As Worksheet
   Dim Wbk As Workbook
   Dim i As Long
   Dim x As Long
'get value from A7 to get workbook B name
   Set Wbk = Workbooks(ThisWorkbook.Sheets("Main").Range("A7").Value)
i = 4   'set at 4 so starts at 5 
   For Each Ws In Wbk.Worksheets
'get sheet names but not these specific names
   If Ws.Visible = xlSheetVisible And Ws.Name <> ("QPriceSheet") And Ws.Name <> ("TotalJobCost") And Ws.Name <> ("Break Out Prices") And Ws.Name <> ("Order Entry") Then
       i = i + 1
      ThisWorkbook.Sheets("Main").Range("C" & i).Value = Ws.Name
      Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = Ws.Name
     End If
     Next
ThisWorkbook.Worksheets("Main").Range("A:A,C:C").EntireColumn.AutoFit 'Columns A & C
End Sub

However, what i want to do is to copy data from the sheet in workbook B from cells A5 to A64 from the specific sheet, to the newly created sheet with the same name in workbook A, then move onto the next worksheet.

I have tried and tried and cannot manage to get this extra information.

As ever, any help is much appreciated.
Thanks
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,761
Untested. Please trial on a copy of your workbook. Seems like it should work. Good luck. Dave
Code:
Sub Everything()
Dim mySh As Worksheet, Ws As Worksheet
   Dim Wbk As Workbook
   Dim i As Long
   Dim x As Long
Dim LastRowA As Integer, LastRowB As Integer
Dim InPutLastRowA As Integer, InPutLastRowC As Integer
'get value from A7 to get workbook B name
  
'just A5-A64 and C5-C64 A vould go into column A in WB A, C can go into column B in WB A.
With ThisWorkbook.Sheets("Main")
LastRowA = .Range("A" & .Rows.Count).End(xlUp).Row
LastRowB = .Range("B" & .Rows.Count).End(xlUp).Row
End With

Set Wbk = Workbooks(ThisWorkbook.Sheets("Main").Range("A7").Value)
i = 4   'set at 4 so starts at 5
'For Each Ws In Wbk.Worksheets
For Each Ws In Workbooks(Wbk.Name).Sheets
'get sheet names but not these specific names
If Ws.Visible = xlSheetVisible And Ws.Name <> ("QPriceSheet") And _
     Ws.Name <> ("TotalJobCost") And Ws.Name <> ("Break Out Prices") And Ws.Name <> ("Order Entry") Then
i = i + 1
ThisWorkbook.Sheets("Main").Range("C" & i).Value = Ws.Name
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
ThisWorkbook.Sheets(Sheets.Count).Name = Ws.Name

With Wbk(Ws.Name)
InPutLastRowA = .Range("A" & .Rows.Count).End(xlUp).Row
InPutLastRowC = .Range("C" & .Rows.Count).End(xlUp).Row
'Popluate correct work sheets in WB A from data in A5-A64, & C5-C64 from WB B
' just A5-A64 and C5-C64 A vould go into column A in WB A, C can go into column B in WB A.
.Range(.Cells(5, "A"), .Cells(InPutLastRowA + 1, "A")).Copy _
Destination:=ThisWorkbook.Sheets("Main").Range("A" & LastRowA + 1)
Application.CutCopyMode = False

.Range(.Cells(5, "C"), .Cells(InPutLastRowC + 1, "C")).Copy _
Destination:=ThisWorkbook.Sheets("Main").Range("B" & LastRowB + 1)
Application.CutCopyMode = False
End With
 
End If
Next Ws
ThisWorkbook.Worksheets("Main").Range("A:A,C:C").EntireColumn.AutoFit 'Columns A & C
End Sub
 

Some videos you may like

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,761
Whoops...
Code:
Sub Everything()
Dim mySh As Worksheet, Ws As Worksheet
   Dim Wbk As Workbook
   Dim i As Long
   Dim x As Long
Dim LastRowA As Integer, LastRowB As Integer
Dim InPutLastRowA As Integer, InPutLastRowC As Integer
'get value from A7 to get workbook B name
  
Set Wbk = Workbooks(ThisWorkbook.Sheets("Main").Range("A7").Value)
i = 4   'set at 4 so starts at 5
'For Each Ws In Wbk.Worksheets
For Each Ws In Workbooks(Wbk.Name).Sheets
'get sheet names but not these specific names
If Ws.Visible = xlSheetVisible And Ws.Name <> ("QPriceSheet") And _
     Ws.Name <> ("TotalJobCost") And Ws.Name <> ("Break Out Prices") And Ws.Name <> ("Order Entry") Then
i = i + 1
ThisWorkbook.Sheets("Main").Range("C" & i).Value = Ws.Name
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
ThisWorkbook.Sheets(Sheets.Count).Name = Ws.Name

'just A5-A64 and C5-C64 A vould go into column A in WB A, C can go into column B in WB A.
With ThisWorkbook.Sheets("Main")
LastRowA = .Range("A" & .Rows.Count).End(xlUp).Row
LastRowB = .Range("B" & .Rows.Count).End(xlUp).Row
End With

With Wbk(Ws.Name)
InPutLastRowA = .Range("A" & .Rows.Count).End(xlUp).Row
InPutLastRowC = .Range("C" & .Rows.Count).End(xlUp).Row
'Popluate correct work sheets in WB A from data in A5-A64, & C5-C64 from WB B
' just A5-A64 and C5-C64 A vould go into column A in WB A, C can go into column B in WB A.
.Range(.Cells(5, "A"), .Cells(InPutLastRowA + 1, "A")).Copy _
Destination:=ThisWorkbook.Sheets("Main").Range("A" & LastRowA + 1)
Application.CutCopyMode = False

.Range(.Cells(5, "C"), .Cells(InPutLastRowC + 1, "C")).Copy _
Destination:=ThisWorkbook.Sheets("Main").Range("B" & LastRowB + 1)
Application.CutCopyMode = False
End With
 
End If
Next Ws
ThisWorkbook.Worksheets("Main").Range("A:A,C:C").EntireColumn.AutoFit 'Columns A & C
End Sub
Dave
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,761
Whoops x2... this looks wrong...
Code:
With Wbk(Ws.Name)
should maybe be...
Code:
With Wbk.Sheets.(Ws.Name)
Dave
 

m_in_spain

Board Regular
Joined
Sep 28, 2018
Messages
55
I finally figured this out all by myself :)
It might be a bit messy, but it works!!!
I guess it is also more rewarding if able to plod thru all this. In case anyone is interested, here is the finished code which does exactly what i tried to describe above:
VBA Code:
Sub DoEverything()
Dim mySh As Worksheet, ws As Worksheet
    Dim Wbk As Workbook
    Dim i As Long
    Dim x As Long
    Dim cell, selcell As Range
    Dim Value As String
    Dim Folder As Variant, a As Long
    Dim r, Lrow As Single
    Dim CWB As Workbook
    Dim MVC As Workbook
    ReDim Folders(0)
        Range("a5").Value = ActiveWorkbook.Path
        Set cell = Range("A9")
        Set selcell = Selection
        Range("A9:B10000").Value = ""
        Folderpath = ActiveWorkbook.Path
            If Right(Folderpath, 1) <> "\" Then
            Folderpath = Folderpath & "\"
            End If
        Value = Dir(Folderpath, &H1F)
            Do Until Value = ""
                If Value Like "~*" Then Value = "."
                    If Value <> "." And Value <> ".." And Value <> ThisWorkbook.Name And Value <> "~" Then
                        If GetAttr(Folderpath & Value) <> 16 Then
                            If Right(Value, 4) = ".xls" Or Right(Value, 5) = ".xlsx" Or Right(Value, 5) = ".xlsm" Then
                cell.Offset(0, 0).Value = Value
                Set cell = cell.Offset(1, 0)
                            End If
                    End If
                End If
        Value = Dir
        Loop
        selcell.Select


        Folderpath = Range("A5").Value
        Set CWB = ActiveWorkbook
            If Right(Folderpath, 1) <> "\" Then
            Folderpath = Folderpath & "\"
            End If
    Application.ScreenUpdating = False
            Workbooks.Open Filename:=Folderpath & Range("A9").Value
            ActiveWindow.WindowState = xlMinimized
            CWB.Activate
    ActiveWindow.Visible = True
    Set Wbk = Workbooks(ThisWorkbook.Sheets("Main").Range("A9").Value)
    i = 4
   For Each ws In Wbk.Worksheets
        If ws.Visible = xlSheetVisible And ws.Name <> ("QPriceSheet") And ws.Name <> ("TotalJobCost") And ws.Name <> ("Break Out Prices") And ws.Name <> ("Order Entry") Then
      i = i + 1
        ThisWorkbook.Sheets("Main").Range("C" & i).Value = ws.Name
        End If
    Next
    ThisWorkbook.Worksheets("Main").Range("A:A,C:C").EntireColumn.AutoFit

On Error Resume Next
    Dim shN As String
    Dim shName As String
    Dim wb As Workbook
    Dim wb2 As Workbook
    Set mywb = ThisWorkbook
    Dim g As Long
    Dim p As Long
    Dim L As Long, c As Long
    Dim myPath
    myPath = Sheet1.Range("A5").Value
    Dim myFile
    myFile = Sheet1.Range("A9").Value

        shN = Sheets("ProjOutput")
            g = 5
            Lastrow = Cells(Rows.Count, "C").End(xlUp).Row
            For g = 5 To Lastrow
        shName = Sheet1.Range("C" & g)
        Set ws = ThisWorkbook.Sheets(shName)
    
    wb2 = (Sheet1.Range("A9").Value)
        Workbooks.Open Filename:=myPath & "\" & myFile
        Sheets(shName).Select
        Range("a5:a64,c5:c64").Copy
    With mywb
    
    Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues

        Sheet2.Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        
        Application.CutCopyMode = False
        
        Range("A1").Select
        
    End With
    mywb.Activate
    'g = g + 1
    Next
        For Each wb In Application.Workbooks
        If Not (wb Is Application.ActiveWorkbook) Then
        wb.Close savechanges:=False
        End If
    Next
       
    Range("A1").Select
    Dim Firstrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
        With ActiveSheet
        .Select
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView
        .DisplayPageBreaks = False
        Firstrow = .UsedRange.Cells(1).Row
        Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
        For Lrow = Lastrow To Firstrow Step -1
            With .Cells(Lrow, "B")
                If Not IsError(.Value) Then
                    If .Value = 0 Then .EntireRow.Delete
                End If
            End With
        Next Lrow
    End With
    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With
    ThisWorkbook.Worksheets("ProjOutput").Range("A:A,B:B").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
 

m_in_spain

Board Regular
Joined
Sep 28, 2018
Messages
55
P.S. Thanks also Dave, for some reason i did not get the alert email that you had posted answers. I will take a look at that too, thanks
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,761
Thanks m for posting your outcome. Not sure why U weren't alerted? Anyways my posted code was untested and was difficult to foresee the outcome without the actual wb... seemed like it should work. Glad U got it sorted out. Be safe. Dave
 

Watch MrExcel Video

Forum statistics

Threads
1,127,164
Messages
5,623,109
Members
415,955
Latest member
ssheldon2021

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top