I was hoping someone could help me make some adjustments to this code here. I found this code here: https://gist.github.com/danwagnerco/040402917376969bf362 and am trying to repurpose it and make some edits but keep running into trouble. Ultametly what the purpose of the code is is to pull data from from several tabs (starting at O7:T7, the data starts in the same range for each tab, some tabs may not have data and can be skipped (although these tabs have formulas with double quotes instead). Also, if there is data the data there won't be any blank spaces (so if row 11 has data then so does 7,8,9, and 10)
The areas that I'm having trouble with I wrote notes within the code, which is all of the text in full caps. I've spent probably close to 15 hours trying to get this to work and ended up repurposing this code here. Any help with this would be greatly appreciated!!
Thanks.
Option Explicit
Public Sub CombineDataFromAllSheets()
Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
'Notes: "Src" is short for "Source", "Dst" is short for "Destination"
'Set references up-front
Set wksDst = ThisWorkbook.Worksheets("AOD")
lngDstLastRow = LastOccupiedRowNum(wksDst) '<- defined below
lngLastCol = LastOccupiedColNum(wksDst) '<- defined below
'Set the initial destination range
Set rngDst = wksDst.Cells(lngDstLastRow 1, 1)
'Loop through all sheets
For Each wksSrc In ThisWorkbook.Worksheets
'Skip template sheet
'WOULD LIKE TO ADD AN OR STATEMENT HERE, SOMETHING LIKE NAME <> "TEMPLATE" OR "LIST" THEN
If wksSrc.Name <> "Template" Then
'WOULD LIKE THIS TO SEARCH FOR LAST ROW WITH DATA THAT ISN'T DOUBLE QUOTES/A FORMULA WITH NO VISIBLE VALUES
'Identify the last occupied row on this sheet
lngSrcLastRow = LastOccupiedRowNum(wksSrc)
'Store the source data then copy it to the destination range
'WOULD LIKE TO ONLY COPY DATA IF THERE ARE VALUES IN CELLS, BUT MACRO IS PICKING UP CELLS WITH DOUBLE QUOTES
'WOULD LIKE FOR THE MACRO TO ONLY COPY IF DATA EXISTS IN RANGE "O7:T7", IF DATA EXISTS HERE, CONTINUE TO COPY ALL DATA BELOW UNTIL CELLS ARE EMPTY (SKIP CELLS WITH "" AS VALUES)
'WOULD LIKE TO COPY AND PASTE SPECIAL INSTEAD OF FORMULAS
With wksSrc
Set rngSrc = .Range("O7:T7")
rngSrc.Copy Destination:=rngDst
End With
'Redefine the destination range now that new data has been added
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow 1, 1)
End If
Next wksSrc
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last row
'OUTPUT : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last column
'OUTPUT : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function
CodePudding user response：
Okay,
Option Explicit
Sub Pull_All_To_AOD()
Dim wksSrc As Worksheet 'Source Sheet
Dim wksDst As Worksheet 'Destination Sheet
Dim rngSrc As Range 'Source Range
Dim rngDst As Range 'Destination Range
Dim RowCount As Long
Set wksDst = ThisWorkbook.Worksheets("AOD")
'Iterate Worksheets
For Each wksSrc In ThisWorkbook.Worksheets
'Skip Template, AOD, and empty sheets
If wksSrc.Name <> "Template" And _
wksSrc.Name <> "AOD" And _
Trim(Application.WorksheetFunction.Concat(wksSrc.Range("O7:T7"))) <> "" Then
'Find Data Size
RowCount = wksSrc.Range("O" & Rows.Count).End(xlUp).Row - 6
'Copy Data to AOD sheet, next empty row
wksDst.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(RowCount, 6).Value = _
wksSrc.Range("O7").Resize(RowCount, 6).Value
End If
Next wksSrc
End Sub
I think this is what you're looking for. Let me know if I'm missing anything.
CodePudding user response：
Copy Data From Multiple Worksheets
Option Explicit
Sub CombineDataWorksheets()
' Define constants.
' Source
Const sFirstRowAddress As String = "O7:T7"
' The following two constants are related!
Const sNameExceptionsList As String = "AOD,Template,List"
Const sNameExceptionsDelimiter As String = ","
' Destination
Const dName As String = "AOD"
Const dFirstColumn As String = "A"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Write the number of worksheet rows to a variable ('wsrCount').
Dim wsrCount As Long: wsrCount = dws.Rows.Count
' Using the destination worksheet with the source first row address,
' write the following three source properties to variables.
Dim cCount As Long ' Source/Destination Columns Count
Dim sfRow As Long ' Source First Row
Dim scrgAddress As String ' Source Columns Range Address
With dws.Range(sFirstRowAddress)
cCount = .Columns.Count
sfRow = .Row
scrgAddress = .Resize(wsrCount - sfRow 1).Address
End With
' Reference the destination first row range.
Dim dfrrg As Range ' Destination First Row Range
' Attempt to reference the last destination worksheet's row,
' the row of the bottom-most NON-EMPTY cell.
' Note that the Find method with its LookIn argument's parameter
' set to 'xlFormulas' will fail if the worksheet is filtered.
' It will NOT fail if rows or columns are just hidden.
Dim dlCell As Range
Set dlCell = dws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If dlCell Is Nothing Then ' the destination worksheet is empty
Set dfrrg = dws.Cells(1, dFirstColumn).Resize(, cCount)
Else ' the destination worksheet is not empty
Set dfrrg = dws.Cells(dlCell.Row 1, dFirstColumn).Resize(, cCount)
End If
' Write the names from the name exception list to a zero-based string array,
' the name exceptions array ('sNameExceptions').
Dim sNameExceptions() As String
sNameExceptions = Split(sNameExceptionsList, sNameExceptionsDelimiter)
' Declare additional variables to be used in the loop.
Dim sws As Worksheet ' Source Worksheet
Dim srg As Range ' Source Range
Dim slCell As Range ' Source Last Cell
Dim rCount As Long ' Source/Destination Rows Count
Dim drg As Range ' Destination Range
' Loop through the worksheets collection of the workbook...
For Each sws In wb.Worksheets
' Check if the source name was NOT found in the name exceptions array.
If IsError(Application.Match(sws.Name, sNameExceptions, 0)) Then
' Reference the source columns range, the range from the first
' source row range to the bottom-most worksheet row range.
With sws.Range(scrgAddress)
' Attempt to reference the source worksheet's last row,
' the row of the bottom-most NON-BLANK cell.
' Note that the Find method with its LookIn argument's
' parameter set to 'xlValues' will fail if the worksheet
' is filtered, and even if rows or columns are just hidden.
Set slCell = .Find("*", , xlValues, , xlByRows, xlPrevious)
' Check if a source non-blank cell was found.
If Not slCell Is Nothing Then ' non-blank cell found
' Calculate the number of source/destination rows.
rCount = slCell.Row - sfRow 1
' Reference the source range.
Set srg = .Resize(rCount)
' Reference the destination range.
Set drg = dfrrg.Resize(rCount)
' Write the values from the source to the destination range.
drg.Value = srg.Value
' Reference the next destination first row range.
Set dfrrg = dfrrg.Offset(rCount)
'Else ' non-blank cell not found; do nothing
End If
End With
'Else ' worksheet name is in the name exceptions array; do nothing
End If
Next sws
' Inform.
MsgBox "Data combined.", vbInformation
End Sub