Sub MrE161350C_CopyValues()
'https://www.mrexcel.com/board/threads/vba-for-copying-all-data-from-8-sheets-in-a-single-workbook-to-a-new-sheet-in-new-workbook.1220016/
'/// changed by HaHoBe, 221105
'/// reason: user request for values only in Target Sheet
Dim wbWork As Workbook
Dim wbNew As Workbook
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim blnRngCopy As Boolean
Dim lngStart As Long
Dim lngCounter As Long
Dim lngLastRow As Long
Dim lngEmptyRows As Long
Dim lngStartRow As Long
Dim lngCalcMeth As Long
Dim rng2Copy As Range
Dim rngCell As Range
Dim rngArea As Range
Dim strColumn As String
Dim strSC As String
Dim strStartCol As String
Dim strEndCol As String
Dim strDestCol As String
'no screen update, calculation is set to Manual
With Application
.ScreenUpdating = False
lngCalcMeth = .Calculation
.Calculation = xlCalculationManual
End With
On Error GoTo err_here
'!!! workbook must be open, please change name and extension to suit
Set wbWork = Workbooks("sdhasan Taxi Master Attendance_Sample Festwerte.xlsx")
Set wbNew = Workbooks.Add(1)
Set wsNew = wbNew.Sheets(1)
wsNew.Range("A1:M1").Value = wbWork.Worksheets("Airport Taxi").Range("A4:M4").Value
lngStart = 2
For Each ws In wbWork.Worksheets
Select Case ws.Name
Case "Airport Taxi", "Airport Taxi (Temp. driver)", "Karwa White", "Karwa White (Temporary)"
With ws
For lngCounter = 1 To 4
blnRngCopy = True
Select Case lngCounter
Case 1
strColumn = "C": strStartCol = "A": strEndCol = "M": strDestCol = "A"
Case 2
strColumn = "N": strStartCol = "N": strEndCol = "U": strDestCol = "B"
lngStart = wsNew.Cells(Rows.Count, "A").End(xlUp).Row + 1
Case 3
strColumn = "O": strStartCol = "O": strEndCol = "O": strDestCol = "A"
Case 4
strColumn = "O": strStartCol = "J": strEndCol = "M": strDestCol = "J"
Case Else
strColumn = "O": strStartCol = vbNullString: strEndCol = vbNullString: strDestCol = "J"
End Select
lngStartRow = 5
lngLastRow = fncGetLastFilledRow(ws, Range(strColumn & ":" & strColumn).Address)
If lngLastRow > 0 Then
lngEmptyRows = WorksheetFunction.CountBlank(.Range(strColumn & lngStartRow & ":" & strColumn & lngLastRow))
If lngLastRow >= lngStartRow Then
Select Case lngEmptyRows
Case Is > 0
If .Range(strColumn & lngLastRow).HasFormula Then
strSC = xlCellTypeFormulas
Else
strSC = xlCellTypeConstants
End If
Select Case lngCounter
Case 1, 2
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strStartCol & lngLastRow).SpecialCells(strSC)
If rng2Copy.Areas.Count = 1 Then
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strEndCol & lngLastRow).SpecialCells(strSC)
Else
For Each rngArea In rng2Copy.Areas
For Each rngCell In rngArea
'/// begin change 221105_01
'/// HaHoBe, 221105
'/// user request for values only in Target Sheet
'///
'/// disabled codelines
' .Range(rngCell, rngCell.Offset(0, 7)).Copy _
' wsNew.Cells(Rows.Count, strDestCol).End(xlUp).Offset(1, 0)
' .Range(.Range("J" & rngCell.Row), .Range("M" & rngCell.Row)).Copy _
' wsNew.Range("J" & wsNew.Cells(Rows.Count, "A").End(xlUp).Row + 1)
' .Range(rngCell, rngCell.Offset(0, 7)).Copy _
' wsNew.Cells(Rows.Count, strDestCol).End(xlUp).Offset(1, 0)
'/// new codeline(s)
wsNew.Range("J" & wsNew.Cells(Rows.Count, "A").End(xlUp).Row + 1).Value = _
.Range(.Range("J" & rngCell.Row), .Range("M" & rngCell.Row)).Value
wsNew.Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = .Range("A" & rngCell.Row).Value
wsNew.Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = .Range("A" & rngCell.Row).Value
'/// end change 221105_01
Next rngCell
Next rngArea
blnRngCopy = False
End If
Case 3, 4
blnRngCopy = False
End Select
Case Else
Select Case lngCounter
Case 1, 2, 4
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strEndCol & lngLastRow)
Case 3
Set rng2Copy = .Range("A" & lngStartRow & ":A" & lngLastRow)
End Select
End Select
'/// begin change 221105_02
'/// HaHoBe, 221105
'/// user request for values only in Target Sheet
'///
'/// disabled codelines
' If blnRngCopy Then rng2Copy.Copy wsNew.Cells(lngStart, strDestCol)
'/// new codeline(s)
If blnRngCopy Then wsNew.Cells(lngStart, strDestCol).Resize(rng2Copy.Rows.Count, rng2Copy.Columns.Count).Value = rng2Copy.Value
'/// end change 221105_02
End If
Else
Select Case MsgBox("Problems copying data from Sheet '" & .Name & "*." & vbCrLf & _
"Cancel or Continue?", vbOKCancel, "Now what...?")
Case vbCancel
wbNew.Close False
GoTo end_here
Case Else
'continue
End Select
End If
Next lngCounter
End With
Case "Revenue Share Scheme"
blnRngCopy = True
lngStartRow = 5
With ws
strColumn = "C": strStartCol = "A": strEndCol = "M": strDestCol = "A"
lngLastRow = fncGetLastFilledRow(ws, Range(strColumn & ":" & strColumn).Address)
If lngLastRow > 0 Then
lngEmptyRows = WorksheetFunction.CountBlank(.Range(strColumn & lngStartRow & ":" & strColumn & lngLastRow))
If lngLastRow >= lngStartRow Then
Select Case lngEmptyRows
Case Is > 0
If .Range(strColumn & lngLastRow).HasFormula Then
strSC = xlCellTypeFormulas
Else
strSC = xlCellTypeConstants
End If
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strStartCol & lngLastRow).SpecialCells(strSC)
If rng2Copy.Areas.Count = 1 Then
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strEndCol & lngLastRow).SpecialCells(strSC)
Else
For Each rngArea In rng2Copy.Areas
For Each rngCell In rngArea
'/// begin change 221105_03
'/// HaHoBe, 221105
'/// user request for values only in Target Sheet
'///
'/// disabled codelines
' .Range(.Cells(rngCell.Row, strStartCol), .Cells(rngCell.Row, strEndCol)).Copy _
' wsNew.Cells(Rows.Count, strDestCol).End(xlUp).Offset(1)
'/// new codeline(s)
wsNew.Cells(Rows.Count, strDestCol).End(xlUp).Offset(1).Value = _
.Range(.Cells(rngCell.Row, strStartCol), .Cells(rngCell.Row, strEndCol)).Value
'/// end change 221105_03
Next rngCell
Next rngArea
blnRngCopy = False
End If
Case Else
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strEndCol & lngLastRow)
End Select
'/// begin change 221105_04
'/// HaHoBe, 221105
'/// user request for values only in Target Sheet
'///
'/// disabled codelines
' If blnRngCopy Then rng2Copy.Copy wsNew.Cells(lngStart, strDestCol)
'/// new codeline(s)
If blnRngCopy Then wsNew.Cells(lngStart, strDestCol).Resize(rng2Copy.Rows.Count, rng2Copy.Columns.Count).Value = rng2Copy.Value
'/// end change 221105_04
Else
Select Case MsgBox("Problems copying data from Sheet '" & .Name & "'." & vbCrLf & _
"Cancel or Continue?", vbOKCancel, "Now what...?")
Case vbCancel
wbNew.Close False
GoTo end_here
Case Else
'continue
End Select
End If
End If
End With
Case "Annual Leave"
blnRngCopy = True
lngStartRow = 3
With ws
strColumn = "C": strStartCol = "A": strEndCol = "G": strDestCol = "A"
lngLastRow = fncGetLastFilledRow(ws, Range(strColumn & ":" & strColumn).Address)
If lngLastRow > 0 Then
lngEmptyRows = WorksheetFunction.CountBlank(.Range(strColumn & lngStartRow & ":" & strColumn & lngLastRow))
If lngLastRow >= lngStartRow Then
Select Case lngEmptyRows
Case Is > 0
If .Range(strColumn & lngLastRow).HasFormula Then
strSC = xlCellTypeFormulas
Else
strSC = xlCellTypeConstants
End If
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strStartCol & lngLastRow).SpecialCells(strSC)
If rng2Copy.Areas.Count = 1 Then
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strEndCol & lngLastRow).SpecialCells(strSC)
Else
For Each rngArea In rng2Copy.Areas
For Each rngCell In rngArea
'/// begin change 221105_05
'/// HaHoBe, 221105
'/// user request for values only in Target Sheet
'///
'/// disabled codelines
' .Range(.Cells(rngCell.Row, strStartCol), .Cells(rngCell.Row, strEndCol)).Copy _
' wsNew.Cells(Rows.Count, strDestCol).End(xlUp).Offset(1)
'/// new codeline(s)
wsNew.Cells(Rows.Count, strDestCol).End(xlUp).Offset(1).Resize(1, 7).Value = _
.Range(.Cells(rngCell.Row, strStartCol), .Cells(rngCell.Row, strEndCol)).Value
'/// end change 221105_05
Next rngCell
Next rngArea
blnRngCopy = False
End If
Case Else
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strEndCol & lngLastRow)
End Select
'/// begin change 221105_06
'/// HaHoBe, 221105
'/// user request for values only in Target Sheet
'///
'/// disabled codelines
' If blnRngCopy Then rng2Copy.Copy wsNew.Cells(lngStart, strDestCol)
'/// new codeline(s)
If blnRngCopy Then wsNew.Cells(lngStart, strDestCol).Resize(rng2Copy.Rows.Count, rng2Copy.Columns.Count).Value = rng2Copy.Value
'/// end change 221105_06
End If
Else
Select Case MsgBox("Problems copying data from Sheet '" & .Name & "'." & vbCrLf & _
"Cancel or Continue?", vbOKCancel, "Now what...?")
Case vbCancel
wbNew.Close False
GoTo end_here
Case Else
'continue
End Select
End If
End With
Case "Resign & Termination"
blnRngCopy = True
lngStartRow = 2
With ws
strColumn = "C": strStartCol = "A": strEndCol = "E": strDestCol = "A"
lngLastRow = fncGetLastFilledRow(ws, Range(strColumn & ":" & strColumn).Address)
If lngLastRow > 0 Then
lngEmptyRows = WorksheetFunction.CountBlank(.Range(strColumn & lngStartRow & ":" & strColumn & lngLastRow))
If lngLastRow >= lngStartRow Then
Select Case lngEmptyRows
Case Is > 0
If .Range(strColumn & lngLastRow).HasFormula Then
strSC = xlCellTypeFormulas
Else
strSC = xlCellTypeConstants
End If
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strEndCol & lngLastRow).SpecialCells(strSC)
Case Else
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strEndCol & lngLastRow)
End Select
'/// begin change 221105_07
'/// HaHoBe, 221105
'/// user request for values only in Target Sheet
'///
'/// disabled codelines
' If blnRngCopy Then rng2Copy.Copy wsNew.Cells(lngStart, strDestCol)
'/// new codeline(s)
If blnRngCopy Then wsNew.Cells(lngStart, strDestCol).Resize(rng2Copy.Rows.Count, rng2Copy.Columns.Count).Value = rng2Copy.Value
'/// end change 221105_07
End If
Else
Select Case MsgBox("Problems copying data from Sheet '" & .Name & "'." & vbCrLf & _
"Cancel or Continue?", vbOKCancel, "Now what...?")
Case vbCancel
wbNew.Close False
GoTo end_here
Case Else
'continue
End Select
End If
End With
Case "Incident"
With ws
For lngCounter = 1 To 2
blnRngCopy = True
lngStartRow = 2
Select Case lngCounter
Case 1
strColumn = "C": strStartCol = "A": strEndCol = "E": strDestCol = "A"
Case 2
strColumn = "C": strStartCol = "H": strEndCol = "H": strDestCol = "H"
End Select
lngLastRow = fncGetLastFilledRow(ws, Range(strColumn & ":" & strColumn).Address)
If lngLastRow > 0 Then
lngEmptyRows = WorksheetFunction.CountBlank(.Range(strColumn & lngStartRow & ":" & strColumn & lngLastRow))
If lngLastRow >= lngStartRow Then
Select Case lngEmptyRows
Case Is > 0
If .Range(strColumn & lngLastRow).HasFormula Then
strSC = xlCellTypeFormulas
Else
strSC = xlCellTypeConstants
End If
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strEndCol & lngLastRow).SpecialCells(strSC)
Case Else
Set rng2Copy = .Range(strStartCol & lngStartRow & ":" & strEndCol & lngLastRow)
End Select
'/// begin change 221105_08
'/// HaHoBe, 221105
'/// user request for values only in Target Sheet
'///
'/// disabled codelines
' If blnRngCopy Then rng2Copy.Copy wsNew.Cells(lngStart, strDestCol)
'/// new codeline(s)
If blnRngCopy Then wsNew.Cells(lngStart, strDestCol).Resize(rng2Copy.Rows.Count, rng2Copy.Columns.Count).Value = rng2Copy.Value
'/// end change 221105_08
End If
Else
Select Case MsgBox("Problems copying data from Sheet '" & .Name & "'." & vbCrLf & _
"Cancel or Continue?", vbOKCancel, "Now what...?")
Case vbCancel
wbNew.Close False
GoTo end_here
Case Else
'continue
End Select
End If
Next lngCounter
End With
Case Else
End Select
lngStart = wsNew.Cells(Rows.Count, "A").End(xlUp).Row + 1
Next ws
wsNew.Columns(5).NumberFormat = wbWork.Worksheets("Airport Taxi").Range("E5").NumberFormat 'time values
wsNew.Columns(4).Copy wsNew.Range("N1")
wsNew.Range("N1").Value = "Status"
'/// begin change 221105_09
'/// HaHoBe, 221105
'/// user request for values only in Target Sheet
'///
'/// disabled codelines
'With wsNew.UsedRange
' .Value = .Value
' .Borders(xlDiagonalDown).LineStyle = xlNone
' .Borders(xlDiagonalUp).LineStyle = xlNone
' .Borders(xlEdgeLeft).LineStyle = xlNone
' .Borders(xlEdgeTop).LineStyle = xlNone
' .Borders(xlEdgeBottom).LineStyle = xlNone
' .Borders(xlEdgeRight).LineStyle = xlNone
' .Borders(xlInsideVertical).LineStyle = xlNone
' .Borders(xlInsideHorizontal).LineStyle = xlNone
' With .Interior
' .Pattern = xlNone
' .TintAndShade = 0
' .PatternTintAndShade = 0
' End With
' With .Font
' .Name = "Calibri"
' .FontStyle = "Standard"
' .Size = 10
' .Bold = False
' .Strikethrough = False
' .Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
' .ColorIndex = xlAutomatic
' .TintAndShade = 0
' .ThemeFont = xlThemeFontMinor
' End With
' wsNew.ListObjects.Add(xlSrcRange, wsNew.Range("A1").CurrentRegion, , xlYes).Name = "Table1"
' .HorizontalAlignment = xlGeneral
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = False
' .Rows(1).Font.Bold = True
' .EntireColumn.AutoFit
'End With
'/// end change 221105_09
wsNew.Name = "Data " & Format(Now, "yymmdd_hhmmss") 'name sheet
Application.Goto wsNew.Range("A1"), True
With ActiveWindow
.Split = False
.SplitColumn = 2
.SplitRow = 1
.FreezePanes = True
End With
wbNew.SaveAs Application.DefaultFilePath & Application.PathSeparator & wsNew.Name & ".xlsx", FileFormat:=51
end_here:
With Application
.ScreenUpdating = True
' .Calculation = lngCalcMeth
.Calculation = xlCalculationAutomatic
End With
Set rng2Copy = Nothing
Set wsNew = Nothing
Set wbNew = Nothing
Set wbWork = Nothing
Exit Sub
err_here:
If Not ws Is Nothing Then
Debug.Print "Worksheet: " & ws.Name
Debug.Print "ErrNum: " & Err.Number
Debug.Print "ErrTest: " & Err.Description
Debug.Print "lngCounter: " & lngCounter
Debug.Print "strColumn: " & strColumn
Debug.Print "strStartCol: " & strStartCol
Debug.Print "strEndCol: " & strEndCol
Debug.Print "strDestCol: " & strDestCol
Debug.Print "lngLastRow: " & lngLastRow
Debug.Print "lngEmptyRows: " & lngEmptyRows
Debug.Print "strSC: " & strSC
If Not rng2Copy Is Nothing Then Debug.Print "rng2Copy: " & rng2Copy.Address
If Not rngCell Is Nothing Then Debug.Print "rngCell Add: " & rngCell.Address
If Not rngCell Is Nothing Then Debug.Print "rngCell Val: " & rngCell.Value
End If
Err.Clear
Resume end_here
End Sub
Function fncGetLastFilledRow(ws As Worksheet, strCol As String) As Long
Dim varReturn As Variant
On Error GoTo err_here
With ws.Range(strCol)
varReturn = .Find(What:="*", _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
fncGetLastFilledRow = varReturn
Exit Function
err_here:
If Err <> 0 Then
Err.Clear
On Error GoTo 0
End If
End Function
