My latest project

[m_in_spain]

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:

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]

Untested. Please trial on a copy of your workbook. Seems like it should work. Good luck. Dave

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

 

[NdNoviceHlp]

Whoops...

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]

Whoops x2... this looks wrong...

With Wbk(Ws.Name)

should maybe be...

With Wbk.Sheets.(Ws.Name)

Dave

 

[m_in_spain]

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:

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]

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]

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